{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
module Dhall.Import (
load
, loadWithManager
, loadRelativeTo
, loadRelativeToWithManager
, loadWith
, localToPath
, hashExpression
, hashExpressionToCode
, writeExpressionToSemanticCache
, assertNoImports
, Manager
, defaultNewManager
, CacheWarning(..)
, Status(..)
, SemanticCacheMode(..)
, Chained
, chainedImport
, chainedFromLocalHere
, chainedChangeMode
, emptyStatus
, emptyStatusWithManager
, 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 (..), liftA2)
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.CaseInsensitive (CI)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.Void (Void, absurd)
import Dhall.Binary (StandardVersion (..))
import Dhall.Syntax
( Chunks (..)
, Directory (..)
, Expr (..)
, File (..)
, FilePrefix (..)
, Import (..)
, ImportHashed (..)
, ImportMode (..)
, ImportType (..)
, URL (..)
, bindingExprs
, functionBindingExprs
, recordFieldExprs
)
import System.FilePath ((</>))
#ifdef WITH_HTTP
import Dhall.Import.HTTP
#endif
import Dhall.Import.Types
import Dhall.Parser
( ParseError (..)
, Parser (..)
, SourcedException (..)
, Src (..)
)
import Lens.Family.State.Strict (zoom)
import qualified Codec.CBOR.Encoding as Encoding
import qualified Codec.CBOR.Write as Write
import qualified Codec.Serialise
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.CaseInsensitive
import qualified Data.Foldable
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text
import qualified Data.Text.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: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Import -> String
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
"\nReferentially opaque import: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Import -> String
forall a. Pretty a => a -> String
Dhall.Pretty.Internal.prettyToString Import
import_
data Imported e = Imported
{ Imported e -> NonEmpty Chained
importStack :: NonEmpty Chained
, 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) =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Int -> Chained -> String) -> [Int] -> [Chained] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Chained -> String
forall a. Pretty a => Int -> a -> String
indent [Int
0..] [Chained]
toDisplay)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e
where
indent :: Int -> a -> String
indent Int
n a
import_ =
String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"↳ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
Dhall.Pretty.Internal.prettyToString a
import_
canonical :: [Chained]
canonical = NonEmpty Chained -> [Chained]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Chained
canonicalizedImports
toDisplay :: [Chained]
toDisplay = Int -> [Chained] -> [Chained]
forall a. Int -> [a] -> [a]
drop Int
1 ([Chained] -> [Chained]
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"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: Missing file "
String -> ShowS
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"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: Missing environment variable\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
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"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: No valid imports"
show (MissingImports [SomeException
e]) = SomeException -> String
forall a. Show a => a -> String
show SomeException
e
show (MissingImports [SomeException]
es) =
String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: Failed to resolve imports. Error list:"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (SomeException -> String) -> [SomeException] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\SomeException
e -> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n") [SomeException]
es
throwMissingImport :: (MonadCatch m, Exception e) => e -> m a
throwMissingImport :: e -> m a
throwMissingImport e
e = MissingImports -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e])
type = (CI ByteString, ByteString)
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"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: Cannot import HTTP URL.\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Dhall was compiled without the 'with-http' flag.\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"The requested URL was: "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
url
String -> ShowS
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₀)) =
Directory -> Directory
forall path. Canonicalize path => path -> path
canonicalize ([Text] -> Directory
Directory [Text]
components₀)
canonicalize (Directory (Text
".." : [Text]
components₀)) =
case Directory -> Directory
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
".." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
".." Text -> [Text] -> [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 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
components₁)
where
Directory [Text]
components₁ = Directory -> Directory
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 -> Text -> File
File { directory :: Directory
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 (File -> File
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 :: Scheme
-> Text -> File -> Maybe Text -> Maybe (Expr Src Import) -> URL
URL { path :: File
path = File -> File
forall path. Canonicalize path => path -> path
canonicalize File
path, headers :: Maybe (Expr Src Import)
headers = (Expr Src Import -> Expr Src Import)
-> Maybe (Expr Src Import) -> Maybe (Expr Src Import)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Import -> Import) -> Expr Src Import -> Expr Src Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Import -> Import
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 (ImportType -> ImportType
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 (ImportHashed -> ImportHashed
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"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;31mError\ESC[0m: " String -> ShowS
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"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Expected hash:\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SHA256Digest -> String
forall a. Show a => a -> String
show SHA256Digest
expectedHash String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Actual hash:\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SHA256Digest -> String
forall a. Show a => a -> String
show SHA256Digest
actualHash String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
localToPath :: MonadIO io => FilePrefix -> File -> io FilePath
localToPath :: FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file_ = IO String -> io String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> io String) -> IO String -> io String
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 ->
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"/"
FilePrefix
Parent ->
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
".."
FilePrefix
Here ->
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"."
let cs :: [String]
cs = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack (Text
file Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
components)
let cons :: String -> ShowS
cons String
component String
dir = String
dir String -> ShowS
</> String
component
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> ShowS) -> String -> [String] -> String
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 (Import -> Chained) -> Import -> Chained
forall a b. (a -> b) -> a -> b
$
ImportHashed -> ImportMode -> Import
Import (Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed Maybe SHA256Digest
forall a. Maybe a
Nothing (FilePrefix -> File -> ImportType
Local FilePrefix
prefix (File -> File
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
normalizeHeaders URL
url
let child' :: Import
child' = Import
child { importHashed :: ImportHashed
importHashed = ImportHashed
importHashed { importType :: ImportType
importType = URL -> ImportType
Remote URL
url' } }
Chained -> StateT Status IO Chained
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> Chained
Chained (Import -> Import
forall path. Canonicalize path => path -> path
canonicalize (Import
parent Import -> Import -> Import
forall a. Semigroup a => a -> a -> a
<> Import
child')))
chainImport (Chained Import
parent) Import
child =
Chained -> StateT Status IO Chained
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> Chained
Chained (Import -> Import
forall path. Canonicalize path => path -> path
canonicalize (Import
parent Import -> Import -> Import
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
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
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
_remote :: Status -> URL -> StateT Status IO Text
_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
_remote :: URL -> StateT Status IO Text
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
..} <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
case Chained -> Map Chained ImportSemantics -> Maybe ImportSemantics
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Chained
import_ Map Chained ImportSemantics
_cache of
Just ImportSemantics
importSemantics -> ImportSemantics -> StateT Status IO 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_
LensLike' (Zooming IO ()) Status (Map Chained ImportSemantics)
-> StateT (Map Chained ImportSemantics) IO ()
-> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status (Map Chained ImportSemantics)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (Map Chained ImportSemantics)
cache ((Map Chained ImportSemantics -> Map Chained ImportSemantics)
-> StateT (Map Chained ImportSemantics) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Chained
-> ImportSemantics
-> Map Chained ImportSemantics
-> Map Chained ImportSemantics
forall k v. Ord k => k -> v -> Map k v -> Map k v
Dhall.Map.insert Chained
import_ ImportSemantics
importSemantics))
ImportSemantics -> StateT Status IO 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
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remote :: URL -> StateT Status IO Text
_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
_remote :: Status -> URL -> StateT Status IO Text
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
.. } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
Maybe ByteString
mCached <-
case SemanticCacheMode
_semanticCacheMode of
SemanticCacheMode
UseSemanticCache ->
LensLike' (Zooming IO (Maybe ByteString)) Status CacheWarning
-> StateT CacheWarning IO (Maybe ByteString)
-> StateT Status IO (Maybe ByteString)
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO (Maybe ByteString)) Status CacheWarning
forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (SHA256Digest -> StateT CacheWarning IO (Maybe ByteString)
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> m (Maybe ByteString)
fetchFromSemanticCache SHA256Digest
semanticHash)
SemanticCacheMode
IgnoreSemanticCache ->
Maybe ByteString -> StateT Status IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
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 SHA256Digest -> SHA256Digest -> Bool
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 ByteString -> Either DecodingFailure (Expr Void Void)
forall s a.
Serialise (Expr s a) =>
ByteString -> Either DecodingFailure (Expr s a)
Dhall.Binary.decodeExpression ByteString
bytesLazy of
Left DecodingFailure
err -> Imported DecodingFailure -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> DecodingFailure -> Imported DecodingFailure
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack DecodingFailure
err)
Right Expr Void Void
e -> Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
e
ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
ImportSemantics {Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: Expr Void Void
..})
else do
String -> StateT Status IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
printWarning (String -> StateT Status IO ()) -> String -> StateT Status IO ()
forall a b. (a -> b) -> a -> b
$
SHA256Digest -> SHA256Digest -> String
makeHashMismatchMessage SHA256Digest
semanticHash SHA256Digest
actualHash
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
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 variants :: [ByteString]
variants = (StandardVersion -> ByteString)
-> [StandardVersion] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\StandardVersion
version -> StandardVersion -> Expr Void Void -> ByteString
encodeExpression StandardVersion
version (Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a
Core.alphaNormalize Expr Void Void
importSemantics))
[ StandardVersion
forall a. Bounded a => a
minBound .. StandardVersion
forall a. Bounded a => a
maxBound ]
case (ByteString -> Bool) -> [ByteString] -> Maybe ByteString
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.Foldable.find ((SHA256Digest -> SHA256Digest -> Bool
forall a. Eq a => a -> a -> Bool
== SHA256Digest
semanticHash)(SHA256Digest -> Bool)
-> (ByteString -> SHA256Digest) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash) [ByteString]
variants of
Just ByteString
bytes -> LensLike' (Zooming IO ()) Status CacheWarning
-> StateT CacheWarning IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status CacheWarning
forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (SHA256Digest -> ByteString -> StateT CacheWarning IO ()
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
semanticHash ByteString
bytes)
Maybe ByteString
Nothing -> do
let expectedHash :: SHA256Digest
expectedHash = SHA256Digest
semanticHash
Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
let actualHash :: SHA256Digest
actualHash = Expr Void Void -> SHA256Digest
hashExpression (Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a
Core.alphaNormalize Expr Void Void
importSemantics)
Imported HashMismatch -> StateT Status IO ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> HashMismatch -> Imported HashMismatch
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (HashMismatch :: SHA256Digest -> SHA256Digest -> HashMismatch
HashMismatch {SHA256Digest
actualHash :: SHA256Digest
expectedHash :: SHA256Digest
actualHash :: SHA256Digest
expectedHash :: SHA256Digest
..}))
ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
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 :: SHA256Digest -> m (Maybe ByteString)
fetchFromSemanticCache SHA256Digest
expectedHash = MaybeT m ByteString -> m (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT m ByteString -> m (Maybe ByteString))
-> MaybeT m ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
String
cacheFile <- String -> SHA256Digest -> MaybeT m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall" SHA256Digest
expectedHash
Bool
True <- IO Bool -> MaybeT m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
cacheFile)
IO ByteString -> MaybeT m ByteString
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 =
StateT CacheWarning IO () -> CacheWarning -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (SHA256Digest -> ByteString -> StateT CacheWarning IO ()
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
hash ByteString
bytes) CacheWarning
CacheWarned
where
bytes :: ByteString
bytes = StandardVersion -> Expr Void Void -> ByteString
encodeExpression StandardVersion
NoVersion 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 :: SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
hash ByteString
bytes = do
Maybe ()
_ <- MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT m () -> m (Maybe ())) -> MaybeT m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
String
cacheFile <- String -> SHA256Digest -> MaybeT m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall" SHA256Digest
hash
IO () -> MaybeT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
AtomicWrite.Binary.atomicWriteFile String
cacheFile ByteString
bytes)
() -> m ()
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
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remote :: URL -> StateT Status IO Text
_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
_remote :: Status -> URL -> StateT Status IO Text
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
..} <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
String
path <- case ImportType
importType of
Local FilePrefix
prefix File
file -> IO String -> StateT Status IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateT Status IO String)
-> IO String -> StateT Status IO String
forall a b. (a -> b) -> a -> b
$ do
String
path <- FilePrefix -> File -> IO String
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
String
absolutePath <- String -> IO String
Directory.makeAbsolute String
path
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
absolutePath
Remote URL
url -> do
let urlText :: Text
urlText = URL -> Text
forall a. Pretty a => a -> Text
Core.pretty (URL
url { headers :: Maybe (Expr Src Import)
headers = Maybe (Expr Src Import)
forall a. Maybe a
Nothing })
String -> StateT Status IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> String
Text.unpack Text
urlText)
Env Text
env -> String -> StateT Status IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> StateT Status IO String)
-> String -> StateT Status IO String
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
env
ImportType
Missing -> MissingImports -> StateT Status IO String
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [])
let parser :: Parsec Void Text (Expr Src Import)
parser = Parser (Expr Src Import) -> Parsec Void Text (Expr Src Import)
forall a. Parser a -> Parsec Void Text a
unParser (Parser (Expr Src Import) -> Parsec Void Text (Expr Src Import))
-> Parser (Expr Src Import) -> Parsec Void Text (Expr Src Import)
forall a b. (a -> b) -> a -> b
$ do
Parser ()
forall (m :: * -> *). TokenParsing m => m ()
Text.Parser.Token.whiteSpace
Expr Src Import
r <- Parser (Expr Src Import)
Dhall.Parser.expr
Parser ()
forall (m :: * -> *). Parsing m => m ()
Text.Parser.Combinators.eof
Expr Src Import -> Parser (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
r
Expr Src Import
parsedImport <- case Parsec Void Text (Expr Src Import)
-> String
-> Text
-> Either (ParseErrorBundle Text Void) (Expr Src Import)
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 ->
Imported ParseError -> StateT Status IO (Expr Src Import)
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> ParseError -> Imported ParseError
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 -> Expr Src Import -> StateT Status IO (Expr Src Import)
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 (Expr Src Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Core.denote Expr Src Void
resolvedExpr)
Maybe ByteString
mCached <- LensLike' (Zooming IO (Maybe ByteString)) Status CacheWarning
-> StateT CacheWarning IO (Maybe ByteString)
-> StateT Status IO (Maybe ByteString)
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO (Maybe ByteString)) Status CacheWarning
forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (SHA256Digest -> StateT CacheWarning IO (Maybe ByteString)
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 ByteString -> Either DecodingFailure (Expr Void Void)
forall s a.
Serialise (Expr s a) =>
ByteString -> Either DecodingFailure (Expr s a)
Dhall.Binary.decodeExpression ByteString
bytesLazy of
Left DecodingFailure
err -> Imported DecodingFailure -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> DecodingFailure -> Imported DecodingFailure
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack DecodingFailure
err)
Right Expr Void Void
sem -> Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
sem
Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
importSemantics
Maybe ByteString
Nothing -> do
let substitutedExpr :: Expr Src Void
substitutedExpr =
Expr Src Void -> Substitutions Src Void -> Expr Src Void
forall s a. Expr s a -> Substitutions s a -> Expr s a
Dhall.Substitution.substitute Expr Src Void
resolvedExpr Substitutions Src Void
_substitutions
case Expr Src Import -> Expr Src Import
forall s a. Expr s a -> Expr s a
Core.shallowDenote Expr Src Import
parsedImport of
Embed Import
_ ->
Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Core.denote Expr Src Void
substitutedExpr)
Expr Src Import
_ -> do
case Context (Expr Src Void)
-> Expr Src Void -> Either (TypeError Src Void) (Expr Src Void)
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 -> Imported (TypeError Src Void) -> StateT Status IO ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained
-> TypeError Src Void -> Imported (TypeError Src Void)
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack TypeError Src Void
err)
Right Expr Src Void
_ -> () -> StateT Status IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let betaNormal :: Expr t Void
betaNormal =
Maybe (ReifiedNormalizer Void) -> Expr Src Void -> Expr t Void
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 = StandardVersion -> Expr Void Void -> ByteString
encodeExpression StandardVersion
NoVersion Expr Void Void
forall t. Expr t Void
betaNormal
LensLike' (Zooming IO ()) Status CacheWarning
-> StateT CacheWarning IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status CacheWarning
forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (SHA256Digest -> ByteString -> StateT CacheWarning IO ()
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemisemanticCache SHA256Digest
semisemanticHash ByteString
bytes)
Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
forall t. Expr t Void
betaNormal
ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
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 = Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] Text
text)
ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
ImportSemantics {Expr Void Void
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 = Map Text (Maybe (Expr s a)) -> Expr s a
forall s a. Map Text (Maybe (Expr s a)) -> Expr s a
Union (Map Text (Maybe (Expr s a)) -> Expr s a)
-> Map Text (Maybe (Expr s a)) -> Expr s a
forall a b. (a -> b) -> a -> b
$ [(Text, Maybe (Expr s a))] -> Map Text (Maybe (Expr s a))
forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
[ (Text
"Environment", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
Text)
, (Text
"Remote", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
Text)
, (Text
"Local", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
Text)
, (Text
"Missing", Maybe (Expr s a)
forall a. Maybe a
Nothing)
]
let importSemantics :: Expr s a
importSemantics = case ImportType
importType of
ImportType
Missing -> Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr s a
forall s a. Expr s a
locationType (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Missing"
local :: ImportType
local@(Local FilePrefix
_ File
_) ->
Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App (Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr s a
forall s a. Expr s a
locationType (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Local")
(Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (ImportType -> Text
forall a. Pretty a => a -> Text
Core.pretty ImportType
local)))
remote_ :: ImportType
remote_@(Remote URL
_) ->
Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App (Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr s a
forall s a. Expr s a
locationType (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Remote")
(Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (ImportType -> Text
forall a. Pretty a => a -> Text
Core.pretty ImportType
remote_)))
Env Text
env ->
Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App (Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr s a
forall s a. Expr s a
locationType (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Environment")
(Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (Text -> Text
forall a. Pretty a => a -> Text
Core.pretty Text
env)))
ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
ImportSemantics {Expr Void Void
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 :: SHA256Digest -> m (Maybe ByteString)
fetchFromSemisemanticCache SHA256Digest
semisemanticHash = MaybeT m ByteString -> m (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT m ByteString -> m (Maybe ByteString))
-> MaybeT m ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
String
cacheFile <- String -> SHA256Digest -> MaybeT m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall-haskell" SHA256Digest
semisemanticHash
Bool
True <- IO Bool -> MaybeT m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
cacheFile)
IO ByteString -> MaybeT m ByteString
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 :: SHA256Digest -> ByteString -> m ()
writeToSemisemanticCache SHA256Digest
semisemanticHash ByteString
bytes = do
Maybe ()
_ <- MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT m () -> m (Maybe ())) -> MaybeT m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
String
cacheFile <- String -> SHA256Digest -> MaybeT m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall-haskell" SHA256Digest
semisemanticHash
IO () -> MaybeT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
AtomicWrite.Binary.atomicWriteFile String
cacheFile ByteString
bytes)
() -> m ()
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 } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
String
path <- IO String -> StateT Status IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateT Status IO String)
-> IO String -> StateT Status IO String
forall a b. (a -> b) -> a -> b
$ FilePrefix -> File -> IO String
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
Bool
exists <- IO Bool -> StateT Status IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateT Status IO Bool)
-> IO Bool -> StateT Status IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
Directory.doesFileExist String
path
if Bool
exists
then IO Text -> StateT Status IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> StateT Status IO Text)
-> IO Text -> StateT Status IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
Data.Text.IO.readFile String
path
else Imported MissingFile -> StateT Status IO Text
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> MissingFile -> Imported MissingFile
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 } <- StateT Status IO Status
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 } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
Maybe String
x <- IO (Maybe String) -> StateT Status IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> StateT Status IO (Maybe String))
-> IO (Maybe String) -> StateT Status IO (Maybe String)
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 ->
Text -> StateT Status IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
Text.pack String
string)
Maybe String
Nothing ->
Imported MissingEnvironmentVariable -> StateT Status IO Text
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained
-> MissingEnvironmentVariable
-> Imported MissingEnvironmentVariable
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Text -> MissingEnvironmentVariable
MissingEnvironmentVariable Text
env))
fetchFresh ImportType
Missing = MissingImports -> StateT Status IO Text
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
LensLike' (Zooming IO ()) Status (URL -> StateT Status IO Text)
-> StateT (URL -> StateT Status IO Text) IO ()
-> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status (URL -> StateT Status IO Text)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (URL -> StateT Status IO Text)
remote ((URL -> StateT Status IO Text)
-> StateT (URL -> StateT Status IO Text) IO ()
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 = (Expr Src Import -> [HTTPHeader])
-> Maybe (Expr Src Import) -> Maybe [HTTPHeader]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Src Import -> [HTTPHeader]
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
toHeaders :: Expr s a -> [HTTPHeader]
(ListLit Maybe (Expr s a)
_ Seq (Expr s a)
hs) = Seq HTTPHeader -> [HTTPHeader]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (Maybe (Seq HTTPHeader) -> Seq HTTPHeader
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Data.Foldable.fold Maybe (Seq HTTPHeader)
maybeHeaders)
where
maybeHeaders :: Maybe (Seq HTTPHeader)
maybeHeaders = (Expr s a -> Maybe HTTPHeader)
-> Seq (Expr s a) -> Maybe (Seq HTTPHeader)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr s a -> Maybe HTTPHeader
forall s a. Expr s a -> Maybe HTTPHeader
toHeader Seq (Expr s a)
hs
toHeaders Expr s a
_ = []
toHeader :: Expr s a -> Maybe HTTPHeader
(RecordLit Map Text (RecordField s a)
m) = do
(RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
keyText), RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
valueText))
<- Maybe (RecordField s a, RecordField s a)
lookupHeader Maybe (RecordField s a, RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (RecordField s a, RecordField s a)
lookupMapKey
let keyBytes :: ByteString
keyBytes = Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
keyText
let valueBytes :: ByteString
valueBytes = Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
valueText
HTTPHeader -> Maybe HTTPHeader
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
keyBytes, ByteString
valueBytes)
where
lookupHeader :: Maybe (RecordField s a, RecordField s a)
lookupHeader = (RecordField s a
-> RecordField s a -> (RecordField s a, RecordField s a))
-> Maybe (RecordField s a)
-> Maybe (RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"header" Map Text (RecordField s a)
m) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"value" Map Text (RecordField s a)
m)
lookupMapKey :: Maybe (RecordField s a, RecordField s a)
lookupMapKey = (RecordField s a
-> RecordField s a -> (RecordField s a, RecordField s a))
-> Maybe (RecordField s a)
-> Maybe (RecordField s a)
-> Maybe (RecordField s a, RecordField s a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"mapKey" Map Text (RecordField s a)
m) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Text
"mapValue" Map Text (RecordField s a)
m)
toHeader Expr s a
_ =
Maybe HTTPHeader
forall (f :: * -> *) a. Alternative f => f a
empty
getCacheFile
:: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m)
=> FilePath -> Dhall.Crypto.SHA256Digest -> m FilePath
getCacheFile :: String -> SHA256Digest -> m String
getCacheFile String
cacheName SHA256Digest
hash = do
String
cacheDirectory <- String -> m String
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" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SHA256Digest -> String
forall a. Show a => a -> String
show SHA256Digest
hash)
String -> m String
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 :: String -> m String
getOrCreateCacheDirectory String
cacheName = do
let warn :: String -> m b
warn String
message = do
CacheWarning
cacheWarningStatus <- m CacheWarning
forall s (m :: * -> *). MonadState s m => m s
State.get
case CacheWarning
cacheWarningStatus of
CacheWarning
CacheWarned -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
printWarning String
message
CacheWarning
CacheNotWarned -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CacheWarning -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put CacheWarning
CacheWarned
m b
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 " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
action String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
dir String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"... the following exception was thrown:\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> IOException -> String
forall a. Show a => a -> String
show IOException
ioex String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> m b
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
(Permissions -> Permissions)
-> (Permissions -> Permissions) -> Permissions -> Permissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Permissions -> Permissions
Directory.setOwnerWritable Bool
True
(Permissions -> Permissions)
-> (Permissions -> Permissions) -> Permissions -> Permissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Permissions -> Permissions
Directory.setOwnerSearchable Bool
True
m () -> (IOException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
(IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> Permissions -> IO ()
Directory.setPermissions String
dir Permissions
private))
(String -> String -> IOException -> m ()
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 <-
m Permissions -> (IOException -> m Permissions) -> m Permissions
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO Permissions -> m Permissions
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Permissions
Directory.getPermissions String
dir))
(String -> String -> IOException -> m Permissions
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
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
let render :: (Permissions -> Bool) -> p
render Permissions -> Bool
f = if Permissions -> Bool
f Permissions
permissions then p
"✓" else p
"✗"
let message :: String
message =
String
"The directory:\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
dir String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"... does not give you permission to read, write, or search files.\n\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"The directory's current permissions are:\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"• " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Permissions -> Bool) -> String
forall p. IsString p => (Permissions -> Bool) -> p
render Permissions -> Bool
Directory.readable String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" readable\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"• " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Permissions -> Bool) -> String
forall p. IsString p => (Permissions -> Bool) -> p
render Permissions -> Bool
Directory.writable String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" writable\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"• " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Permissions -> Bool) -> String
forall p. IsString p => (Permissions -> Bool) -> p
render Permissions -> Bool
Directory.searchable String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" searchable\n"
String -> m ()
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
message
let existsDirectory :: String -> m Bool
existsDirectory String
dir =
m Bool -> (IOException -> m Bool) -> m Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesDirectoryExist String
dir))
(String -> String -> IOException -> m Bool
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 =
m Bool -> (IOException -> m Bool) -> m Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
path))
(String -> String -> IOException -> m Bool
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 =
m () -> (IOException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
Directory.createDirectory String
dir))
(String -> String -> IOException -> m ()
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 <- String -> m Bool
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m Bool
existsDirectory String
dir
if Bool
existsDir
then
String -> m ()
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m ()
assertPermissions String
dir
else do
Bool
existsFile' <- String -> m Bool
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"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
dir String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"... already exists but is not a directory.\n"
String -> m ()
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)
String -> m ()
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m ()
createDirectory String
dir
String -> m ()
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m ()
setPermissions String
dir
String
cacheBaseDirectory <- m String
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"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
directory String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"You can enable caching by creating it if needed and setting read,\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"write and search permissions on it or providing another cache base\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"directory by setting the $XDG_CACHE_HOME environment variable.\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> m ()
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
Alternative m) =>
String -> m ()
assertDirectory String
directory m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> m ()
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
message
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
directory
getCacheBaseDirectory
:: (MonadState CacheWarning m, Alternative m, MonadIO m) => m FilePath
getCacheBaseDirectory :: m String
getCacheBaseDirectory = m String
alternative₀ m String -> m String -> m String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
alternative₁ m String -> m String -> m String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
forall b. m b
alternative₂
where
alternative₀ :: m String
alternative₀ = do
Maybe String
maybeXDGCacheHome <-
IO (Maybe String) -> m (Maybe String)
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 -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
xdgCacheHome
Maybe String
Nothing -> m String
forall (f :: * -> *) a. Alternative f => f a
empty
alternative₁ :: m String
alternative₁
| Bool
isWindows = do
Maybe String
maybeLocalAppDirectory <-
IO (Maybe String) -> m (Maybe String)
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 -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
localAppDirectory
Maybe String
Nothing -> m String
forall (f :: * -> *) a. Alternative f => f a
empty
| Bool
otherwise = do
Maybe String
maybeHomeDirectory <-
IO (Maybe String) -> m (Maybe String)
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 -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
homeDirectory String -> ShowS
</> String
".cache")
Maybe String
Nothing -> m String
forall (f :: * -> *) a. Alternative f => f a
empty
where isWindows :: Bool
isWindows = String
System.Info.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"mingw32"
alternative₂ :: m b
alternative₂ = do
CacheWarning
cacheWarningStatus <- m CacheWarning
forall s (m :: * -> *). MonadState s m => m s
State.get
let message :: String
message =
String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;33mWarning\ESC[0m: "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Could not locate a cache base directory from the environment.\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"You can provide a cache base directory by pointing the $XDG_CACHE_HOME\n"
String -> ShowS
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 ->
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
System.IO.hPutStrLn Handle
System.IO.stderr String
message)
CacheWarning
CacheWarned ->
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CacheWarning -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put CacheWarning
CacheWarned
m b
forall (f :: * -> *) a. Alternative f => f a
empty
normalizeHeaders :: 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 } <- StateT Status IO Status
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 go :: Text -> Text -> m (Expr t Void)
go Text
key₀ Text
key₁ = do
let expected :: Expr Src Void
expected :: Expr Src Void
expected =
Expr Src Void -> Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a -> Expr s a
App Expr Src Void
forall s a. Expr s a
List
( Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
Record (Map Text (RecordField Src Void) -> Expr Src Void)
-> Map Text (RecordField Src Void) -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> RecordField Src Void
forall s a. Expr s a -> RecordField s a
Core.makeRecordField (Expr Src Void -> RecordField Src Void)
-> Substitutions Src Void -> Map Text (RecordField Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[(Text, Expr Src Void)] -> Substitutions Src Void
forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
[ (Text
key₀, Expr Src Void
forall s a. Expr s a
Text)
, (Text
key₁, Expr Src Void
forall s a. Expr s a
Text)
]
)
let suffix_ :: Text
suffix_ = Expr Src Void -> Text
forall a. Pretty a => a -> Text
Dhall.Pretty.Internal.prettyToStrictText Expr Src Void
expected
let annot :: Expr Src Void
annot = case Expr Src Void
loadedExpr of
Note (Src SourcePos
begin SourcePos
end Text
bytes) Expr Src Void
_ ->
Src -> Expr Src Void -> Expr Src Void
forall s a. s -> Expr s a -> Expr s a
Note (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
begin SourcePos
end Text
bytes') (Expr Src Void -> Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a -> Expr s a
Annot Expr Src Void
loadedExpr Expr Src Void
expected)
where
bytes' :: Text
bytes' = Text
bytes Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix_
Expr Src Void
_ ->
Expr Src Void -> Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a -> Expr s a
Annot Expr Src Void
loadedExpr Expr Src Void
expected
()
_ <- case (Expr Src Void -> Either (TypeError Src Void) (Expr Src Void)
forall s. Expr s Void -> Either (TypeError s Void) (Expr s Void)
Dhall.TypeCheck.typeOf Expr Src Void
annot) of
Left TypeError Src Void
err -> Imported (TypeError Src Void) -> m ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained
-> TypeError Src Void -> Imported (TypeError Src Void)
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack TypeError Src Void
err)
Right Expr Src Void
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Expr t Void -> m (Expr t Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Expr t Void
forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize Expr Src Void
loadedExpr)
let handler₀ :: SomeException -> m (Expr t Void)
handler₀ (SomeException
e :: SomeException) = do
let handler₁ :: SomeException -> m a
handler₁ (SomeException
_ :: SomeException) =
Imported SomeException -> m a
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> SomeException -> Imported SomeException
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack SomeException
e)
(SomeException -> m (Expr t Void))
-> m (Expr t Void) -> m (Expr t Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> m (Expr t Void)
forall (m :: * -> *) a. MonadCatch m => SomeException -> m a
handler₁ (Text -> Text -> m (Expr t Void)
forall (m :: * -> *) t.
MonadCatch m =>
Text -> Text -> m (Expr t Void)
go Text
"header" Text
"value")
Expr Src Void
headersExpression' <-
(SomeException -> StateT Status IO (Expr Src Void))
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (Expr Src Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) t.
MonadCatch m =>
SomeException -> m (Expr t Void)
handler₀ (Text -> Text -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) t.
MonadCatch m =>
Text -> Text -> m (Expr t Void)
go Text
"mapKey" Text
"mapValue")
URL -> StateT Status IO URL
forall (m :: * -> *) a. Monad m => a -> m a
return URL
url { headers :: Maybe (Expr Src Import)
headers = Expr Src Import -> Maybe (Expr Src Import)
forall a. a -> Maybe a
Just ((Void -> Import) -> Expr Src Void -> Expr Src Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Void -> Import
forall a. Void -> a
absurd Expr Src Void
headersExpression') }
normalizeHeaders URL
url = URL -> StateT Status IO URL
forall (m :: * -> *) a. Monad m => a -> m a
return URL
url
emptyStatus :: FilePath -> Status
emptyStatus :: String -> Status
emptyStatus = IO Manager -> String -> Status
emptyStatusWithManager IO Manager
defaultNewManager
emptyStatusWithManager :: IO Manager -> FilePath -> Status
emptyStatusWithManager :: IO Manager -> String -> Status
emptyStatusWithManager IO Manager
newManager = IO Manager -> (URL -> StateT Status IO Text) -> String -> Status
emptyStatusWith IO Manager
newManager URL -> StateT Status IO Text
fetchRemote
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
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remote :: URL -> StateT Status IO Text
_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
_remote :: Status -> URL -> StateT Status IO Text
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
..} <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
let parent :: Chained
parent = NonEmpty Chained -> Chained
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₀ ImportMode -> ImportMode -> Bool
forall a. Eq a => a -> a -> Bool
== ImportMode
Location Bool -> Bool -> Bool
|| Bool
referentiallySane
then () -> StateT Status IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Imported ReferentiallyOpaque -> StateT Status IO ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained
-> ReferentiallyOpaque -> Imported ReferentiallyOpaque
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Import -> ReferentiallyOpaque
ReferentiallyOpaque Import
import₀))
let _stack' :: NonEmpty Chained
_stack' = Chained -> NonEmpty Chained -> NonEmpty Chained
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Chained
child NonEmpty Chained
_stack
if Chained
child Chained -> NonEmpty Chained -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty Chained
_stack
then Imported Cycle -> StateT Status IO ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> Cycle -> Imported Cycle
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Import -> Cycle
Cycle Import
import₀))
else () -> StateT Status IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
LensLike' (Zooming IO ()) Status [Depends]
-> StateT [Depends] IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status [Depends]
forall (f :: * -> *). Functor f => LensLike' f Status [Depends]
graph (StateT [Depends] IO () -> StateT Status IO ())
-> (([Depends] -> [Depends]) -> StateT [Depends] IO ())
-> ([Depends] -> [Depends])
-> StateT Status IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Depends] -> [Depends]) -> StateT [Depends] IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (([Depends] -> [Depends]) -> StateT Status IO ())
-> ([Depends] -> [Depends]) -> StateT Status IO ()
forall a b. (a -> b) -> a -> b
$
\[Depends]
edges -> Chained -> Chained -> Depends
Depends Chained
parent Chained
child Depends -> [Depends] -> [Depends]
forall a. a -> [a] -> [a]
: [Depends]
edges
let stackWithChild :: NonEmpty Chained
stackWithChild = Chained -> NonEmpty Chained -> NonEmpty Chained
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Chained
child NonEmpty Chained
_stack
LensLike' (Zooming IO ()) Status (NonEmpty Chained)
-> StateT (NonEmpty Chained) IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status (NonEmpty Chained)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack (NonEmpty Chained -> StateT (NonEmpty Chained) IO ()
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
LensLike' (Zooming IO ()) Status (NonEmpty Chained)
-> StateT (NonEmpty Chained) IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status (NonEmpty Chained)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack (NonEmpty Chained -> StateT (NonEmpty Chained) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put NonEmpty Chained
_stack)
Expr Src Void -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Void Void -> Expr Src Void
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 StateT Status IO (Expr Src Void)
-> (SourcedException MissingImports
-> StateT Status IO (Expr Src Void))
-> StateT Status IO (Expr Src Void)
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
handler₀ :: SourcedException MissingImports -> StateT Status IO (Expr Src Void)
handler₀ (SourcedException (Src SourcePos
begin SourcePos
_ Text
text₀) (MissingImports [SomeException]
es₀)) =
Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b StateT Status IO (Expr Src Void)
-> (SourcedException MissingImports
-> StateT Status IO (Expr Src Void))
-> StateT Status IO (Expr Src Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SourcedException MissingImports -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) a.
MonadThrow m =>
SourcedException MissingImports -> m a
handler₁
where
handler₁ :: SourcedException MissingImports -> m a
handler₁ (SourcedException (Src SourcePos
_ SourcePos
end Text
text₁) (MissingImports [SomeException]
es₁)) =
SourcedException MissingImports -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Src -> MissingImports -> SourcedException MissingImports
forall e. Src -> e -> SourcedException e
SourcedException (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
begin SourcePos
end Text
text₂) ([SomeException] -> MissingImports
MissingImports ([SomeException]
es₀ [SomeException] -> [SomeException] -> [SomeException]
forall a. [a] -> [a] -> [a]
++ [SomeException]
es₁)))
where
text₂ :: Text
text₂ = Text
text₀ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ? " Text -> Text -> 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 = SourcedException MissingImports -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Src -> MissingImports -> SourcedException MissingImports
forall e. Src -> e -> SourcedException e
SourcedException Src
a (MissingImports
e :: MissingImports))
(Src -> Expr Src Void -> Expr Src Void
forall s a. s -> Expr s a -> Expr s a
Note (Src -> Expr Src Void -> Expr Src Void)
-> StateT Status IO Src
-> StateT Status IO (Expr Src Void -> Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Src -> StateT Status IO Src
forall (f :: * -> *) a. Applicative f => a -> f a
pure Src
a StateT Status IO (Expr Src Void -> Expr Src Void)
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (Expr Src Void)
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) StateT Status IO (Expr Src Void)
-> (MissingImports -> StateT Status IO (Expr Src Void))
-> StateT Status IO (Expr Src Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` MissingImports -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) a. MonadThrow m => MissingImports -> m a
handler
Let Binding Src Import
a Expr Src Import
b -> Binding Src Void -> Expr Src Void -> Expr Src Void
forall s a. Binding s a -> Expr s a -> Expr s a
Let (Binding Src Void -> Expr Src Void -> Expr Src Void)
-> StateT Status IO (Binding Src Void)
-> StateT Status IO (Expr Src Void -> Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Src Import -> StateT Status IO (Expr Src Void))
-> Binding Src Import -> StateT Status IO (Binding Src Void)
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 StateT Status IO (Expr Src Void -> Expr Src Void)
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (Expr Src Void)
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 -> Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
Record (Map Text (RecordField Src Void) -> Expr Src Void)
-> StateT Status IO (Map Text (RecordField Src Void))
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordField Src Import -> StateT Status IO (RecordField Src Void))
-> Map Text (RecordField Src Import)
-> StateT Status IO (Map Text (RecordField Src Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Expr Src Import -> StateT Status IO (Expr Src Void))
-> RecordField Src Import
-> StateT Status IO (RecordField Src Void)
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 -> Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit (Map Text (RecordField Src Void) -> Expr Src Void)
-> StateT Status IO (Map Text (RecordField Src Void))
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordField Src Import -> StateT Status IO (RecordField Src Void))
-> Map Text (RecordField Src Import)
-> StateT Status IO (Map Text (RecordField Src Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Expr Src Import -> StateT Status IO (Expr Src Void))
-> RecordField Src Import
-> StateT Status IO (RecordField Src Void)
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 FunctionBinding Src Import
a Expr Src Import
b -> FunctionBinding Src Void -> Expr Src Void -> Expr Src Void
forall s a. FunctionBinding s a -> Expr s a -> Expr s a
Lam (FunctionBinding Src Void -> Expr Src Void -> Expr Src Void)
-> StateT Status IO (FunctionBinding Src Void)
-> StateT Status IO (Expr Src Void -> Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Src Import -> StateT Status IO (Expr Src Void))
-> FunctionBinding Src Import
-> StateT Status IO (FunctionBinding Src Void)
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 StateT Status IO (Expr Src Void -> Expr Src Void)
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (Expr Src Void)
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 -> Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field (Expr Src Void -> FieldSelection Src -> Expr Src Void)
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (FieldSelection Src -> Expr Src Void)
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 StateT Status IO (FieldSelection Src -> Expr Src Void)
-> StateT Status IO (FieldSelection Src)
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldSelection Src -> StateT Status IO (FieldSelection Src)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldSelection Src
b
Expr Src Import
expression -> (Expr Src Import -> StateT Status IO (Expr Src Void))
-> Expr Src Import -> StateT Status IO (Expr Src Void)
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 = IO Manager
-> String
-> SemanticCacheMode
-> Expr Src Import
-> IO (Expr Src Void)
loadRelativeToWithManager IO Manager
newManager String
"." SemanticCacheMode
UseSemanticCache
printWarning :: (MonadIO m) => String -> m ()
printWarning :: String -> m ()
printWarning String
message = do
let warning :: String
warning =
String
"\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;33mWarning\ESC[0m: "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
message
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 = IO Manager
-> String
-> SemanticCacheMode
-> Expr Src Import
-> IO (Expr Src Void)
loadRelativeToWithManager IO Manager
defaultNewManager
loadRelativeToWithManager
:: IO Manager
-> FilePath
-> SemanticCacheMode
-> Expr Src Import
-> IO (Expr Src Void)
loadRelativeToWithManager :: IO Manager
-> String
-> SemanticCacheMode
-> Expr Src Import
-> IO (Expr Src Void)
loadRelativeToWithManager IO Manager
newManager String
rootDirectory SemanticCacheMode
semanticCacheMode Expr Src Import
expression =
StateT Status IO (Expr Src Void) -> Status -> IO (Expr Src Void)
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)
(IO Manager -> String -> Status
emptyStatusWithManager IO Manager
newManager String
rootDirectory) { _semanticCacheMode :: SemanticCacheMode
_semanticCacheMode = SemanticCacheMode
semanticCacheMode }
encodeExpression
:: StandardVersion
-> Expr Void Void
-> Data.ByteString.ByteString
encodeExpression :: StandardVersion -> Expr Void Void -> ByteString
encodeExpression StandardVersion
_standardVersion Expr Void Void
expression = ByteString
bytesStrict
where
intermediateExpression :: Expr Void Import
intermediateExpression :: Expr Void Import
intermediateExpression = (Void -> Import) -> Expr Void Void -> Expr Void Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Void -> Import
forall a. Void -> a
absurd Expr Void Void
expression
encoding :: Encoding
encoding =
case StandardVersion
_standardVersion of
StandardVersion
NoVersion ->
Expr Void Import -> Encoding
forall a. Serialise a => a -> Encoding
Codec.Serialise.encode Expr Void Import
intermediateExpression
StandardVersion
s ->
Word -> Encoding
Encoding.encodeListLen Word
2
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding
Encoding.encodeString Text
v
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Expr Void Import -> Encoding
forall a. Serialise a => a -> Encoding
Codec.Serialise.encode Expr Void Import
intermediateExpression
where
v :: Text
v = StandardVersion -> Text
Dhall.Binary.renderStandardVersion StandardVersion
s
bytesStrict :: ByteString
bytesStrict = Encoding -> ByteString
Write.toStrictByteString Encoding
encoding
hashExpression :: Expr Void Void -> Dhall.Crypto.SHA256Digest
hashExpression :: Expr Void Void -> SHA256Digest
hashExpression Expr Void Void
expression =
ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash (StandardVersion -> Expr Void Void -> ByteString
encodeExpression StandardVersion
NoVersion Expr Void Void
expression)
hashExpressionToCode :: Expr Void Void -> Text
hashExpressionToCode :: Expr Void Void -> Text
hashExpressionToCode Expr Void Void
expr =
Text
"sha256:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (SHA256Digest -> String
forall a. Show a => a -> String
show (Expr Void Void -> SHA256Digest
hashExpression Expr Void Void
expr))
data ImportResolutionDisabled = ImportResolutionDisabled deriving (Show ImportResolutionDisabled
Typeable ImportResolutionDisabled
Typeable ImportResolutionDisabled
-> Show ImportResolutionDisabled
-> (ImportResolutionDisabled -> SomeException)
-> (SomeException -> Maybe ImportResolutionDisabled)
-> (ImportResolutionDisabled -> String)
-> Exception 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
$cp2Exception :: Show ImportResolutionDisabled
$cp1Exception :: Typeable ImportResolutionDisabled
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 :: Expr Src Import -> io (Expr Src Void)
assertNoImports Expr Src Import
expression =
Either ImportResolutionDisabled (Expr Src Void)
-> io (Expr Src Void)
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws ((Import -> Either ImportResolutionDisabled Void)
-> Expr Src Import
-> Either ImportResolutionDisabled (Expr Src Void)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Import
_ -> ImportResolutionDisabled -> Either ImportResolutionDisabled Void
forall a b. a -> Either a b
Left ImportResolutionDisabled
ImportResolutionDisabled) Expr Src Import
expression)
dependencyToFile :: Status -> Import -> IO (Maybe FilePath)
dependencyToFile :: Status -> Import -> IO (Maybe String)
dependencyToFile Status
status Import
import_ = (StateT Status IO (Maybe String) -> Status -> IO (Maybe String))
-> Status -> StateT Status IO (Maybe String) -> IO (Maybe String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Status IO (Maybe String) -> Status -> IO (Maybe String)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT Status
status (StateT Status IO (Maybe String) -> IO (Maybe String))
-> StateT Status IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
Chained
parent :| [Chained]
_ <- LensLike' (Zooming IO (NonEmpty Chained)) Status (NonEmpty Chained)
-> StateT (NonEmpty Chained) IO (NonEmpty Chained)
-> StateT Status IO (NonEmpty Chained)
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO (NonEmpty Chained)) Status (NonEmpty Chained)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack StateT (NonEmpty Chained) IO (NonEmpty Chained)
forall s (m :: * -> *). MonadState s m => m s
State.get
Import
child <- (Chained -> Import)
-> StateT Status IO Chained -> StateT Status IO Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Chained -> Import
chainedImport ((forall a. IO a -> IO a)
-> StateT Status IO Chained -> StateT Status IO Chained
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 a. IO a -> IO a
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 = Maybe a -> StateT Status IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
case Import -> ImportMode
importMode Import
child of
ImportMode
RawText ->
StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore
ImportMode
Location ->
StateT Status IO (Maybe String)
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 = IO (Maybe String) -> StateT Status IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> StateT Status IO (Maybe String))
-> IO (Maybe String) -> StateT Status IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
String
path <- FilePrefix -> File -> IO String
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
filePrefix File
file
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
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
_ -> StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore
Remote{} ->
StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore
ImportType
Missing ->
StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore
Env{} ->
StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore