{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

{-# OPTIONS_GHC -Wall #-}

module Dhall.Import.Types where

import Control.Exception                (Exception)
import Control.Monad.Trans.State.Strict (StateT)
import Data.ByteString                  (ByteString)
import Data.CaseInsensitive             (CI)
import Data.Dynamic
import Data.HashMap.Strict              (HashMap)
import Data.List.NonEmpty               (NonEmpty)
import Data.Void                        (Void)
import Dhall.Context                    (Context)
import Dhall.Core
    ( Expr
    , Import (..)
    , ReifiedNormalizer (..)
    , URL
    )
import Dhall.Map                        (Map)
import Dhall.Parser                     (Src)
import Lens.Family                      (LensLike')
import Prettyprinter                    (Pretty (..))

#ifdef WITH_HTTP
import qualified Dhall.Import.Manager
#endif

import qualified Data.Text
import qualified Dhall.Context
import qualified Dhall.Map          as Map
import qualified Dhall.Substitution

-- | A fully \"chained\" import, i.e. if it contains a relative path that path
--   is relative to the current directory. If it is a remote import with headers
--   those are well-typed (either of type `List { header : Text, value Text}` or
--   `List { mapKey : Text, mapValue Text})` and in normal form. These
--   invariants are preserved by the API exposed by @Dhall.Import@.
newtype Chained = Chained
    { Chained -> Import
chainedImport :: Import
      -- ^ The underlying import
    }
  deriving (Chained -> Chained -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Chained -> Chained -> Bool
$c/= :: Chained -> Chained -> Bool
== :: Chained -> Chained -> Bool
$c== :: Chained -> Chained -> Bool
Eq, Eq Chained
Chained -> Chained -> Bool
Chained -> Chained -> Ordering
Chained -> Chained -> Chained
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Chained -> Chained -> Chained
$cmin :: Chained -> Chained -> Chained
max :: Chained -> Chained -> Chained
$cmax :: Chained -> Chained -> Chained
>= :: Chained -> Chained -> Bool
$c>= :: Chained -> Chained -> Bool
> :: Chained -> Chained -> Bool
$c> :: Chained -> Chained -> Bool
<= :: Chained -> Chained -> Bool
$c<= :: Chained -> Chained -> Bool
< :: Chained -> Chained -> Bool
$c< :: Chained -> Chained -> Bool
compare :: Chained -> Chained -> Ordering
$ccompare :: Chained -> Chained -> Ordering
Ord)

instance Pretty Chained where
    pretty :: forall ann. Chained -> Doc ann
pretty (Chained Import
import_) = forall a ann. Pretty a => a -> Doc ann
pretty Import
import_

-- | An import that has been fully interpeted
newtype ImportSemantics = ImportSemantics
    { ImportSemantics -> Expr Void Void
importSemantics :: Expr Void Void
    -- ^ The fully resolved import, typechecked and beta-normal.
    }

-- | `parent` imports (i.e. depends on) `child`
data Depends = Depends { Depends -> Chained
parent :: Chained, Depends -> Chained
child :: Chained }

{-| This enables or disables the semantic cache for imports protected by
    integrity checks
-}
data SemanticCacheMode = IgnoreSemanticCache | UseSemanticCache deriving (SemanticCacheMode -> SemanticCacheMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SemanticCacheMode -> SemanticCacheMode -> Bool
$c/= :: SemanticCacheMode -> SemanticCacheMode -> Bool
== :: SemanticCacheMode -> SemanticCacheMode -> Bool
$c== :: SemanticCacheMode -> SemanticCacheMode -> Bool
Eq)

-- | Shared state for HTTP requests
type Manager =
#ifdef WITH_HTTP
    Dhall.Import.Manager.Manager
#else
    ()
#endif

-- | The default HTTP 'Manager'
defaultNewManager :: IO Manager
defaultNewManager :: IO Manager
defaultNewManager =
#ifdef WITH_HTTP
  IO Manager
Dhall.Import.Manager.defaultNewManager
#else
  pure ()
#endif

-- | HTTP headers
type HTTPHeader = (CI ByteString, ByteString)

-- | A map of site origin -> HTTP headers
type OriginHeaders = HashMap Data.Text.Text [HTTPHeader]

{-| Used internally to track whether or not we've already warned the user about
    caching issues
-}
data CacheWarning = CacheNotWarned | CacheWarned

-- | State threaded throughout the import process
data Status = Status
    { Status -> NonEmpty Chained
_stack :: NonEmpty Chained
    -- ^ Stack of `Import`s that we've imported along the way to get to the
    -- current point

    , Status -> [Depends]
_graph :: [Depends]
    -- ^ Graph of all the imports visited so far, represented by a list of
    --   import dependencies.

    , Status -> Map Chained ImportSemantics
_cache :: Map Chained ImportSemantics
    -- ^ Cache of imported expressions with their node id in order to avoid
    --   importing the same expression twice with different values

    , Status -> IO Manager
_newManager :: IO Manager
    , Status -> Maybe Manager
_manager :: Maybe Manager
    -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple
    -- requests

    , Status -> StateT Status IO OriginHeaders
_loadOriginHeaders :: StateT Status IO OriginHeaders
    -- ^ Load the origin headers from environment or configuration file.
    --   After loading once, further evaluations return the cached version.

    , Status -> URL -> StateT Status IO Text
_remote :: URL -> StateT Status IO Data.Text.Text
    -- ^ The remote resolver, fetches the content at the given URL.

    , Status -> URL -> StateT Status IO ByteString
_remoteBytes :: URL -> StateT Status IO Data.ByteString.ByteString
    -- ^ Like `_remote`, except for `Dhall.Syntax.Expr.Bytes`

    , Status -> Substitutions Src Void
_substitutions :: Dhall.Substitution.Substitutions Src Void

    , Status -> Maybe (ReifiedNormalizer Void)
_normalizer :: Maybe (ReifiedNormalizer Void)

    , Status -> Context (Expr Src Void)
_startingContext :: Context (Expr Src Void)

    , Status -> SemanticCacheMode
_semanticCacheMode :: SemanticCacheMode

    , Status -> CacheWarning
_cacheWarning :: CacheWarning
    -- ^ Records whether or not we already warned the user about issues with
    --   cache directory
    }

-- | Initial `Status`, parameterised over the HTTP 'Manager',
--   the origin headers and the remote resolver,
--   importing relative to the given root import.
emptyStatusWith
    :: IO Manager
    -> StateT Status IO OriginHeaders
    -> (URL -> StateT Status IO Data.Text.Text)
    -> (URL -> StateT Status IO Data.ByteString.ByteString)
    -> Import
    -> Status
emptyStatusWith :: IO Manager
-> StateT Status IO OriginHeaders
-> (URL -> StateT Status IO Text)
-> (URL -> StateT Status IO ByteString)
-> Import
-> Status
emptyStatusWith IO Manager
_newManager StateT Status IO OriginHeaders
_loadOriginHeaders URL -> StateT Status IO Text
_remote URL -> StateT Status IO ByteString
_remoteBytes Import
rootImport = Status {IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
CacheWarning
SemanticCacheMode
URL -> StateT Status IO ByteString
URL -> StateT Status IO Text
forall {a}. [a]
forall {a}. Maybe a
forall {a}. Context a
forall {v}. Map Chained v
forall {s} {a}. Substitutions s a
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: forall {a}. Context a
_normalizer :: forall {a}. Maybe a
_substitutions :: forall {s} {a}. Substitutions s a
_manager :: forall {a}. Maybe a
_cache :: forall {v}. Map Chained v
_graph :: forall {a}. [a]
_stack :: NonEmpty Chained
_remoteBytes :: URL -> StateT Status IO ByteString
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_newManager :: IO Manager
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remoteBytes :: URL -> StateT Status IO ByteString
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
..}
  where
    _stack :: NonEmpty Chained
_stack = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Import -> Chained
Chained Import
rootImport)

    _graph :: [a]
_graph = []

    _cache :: Map Chained v
_cache = forall k v. Ord k => Map k v
Map.empty

    _manager :: Maybe a
_manager = forall {a}. Maybe a
Nothing

    _substitutions :: Substitutions s a
_substitutions = forall {s} {a}. Substitutions s a
Dhall.Substitution.empty

    _normalizer :: Maybe a
_normalizer = forall {a}. Maybe a
Nothing

    _startingContext :: Context a
_startingContext = forall {a}. Context a
Dhall.Context.empty

    _semanticCacheMode :: SemanticCacheMode
_semanticCacheMode = SemanticCacheMode
UseSemanticCache

    _cacheWarning :: CacheWarning
_cacheWarning = CacheWarning
CacheNotWarned

-- | Lens from a `Status` to its `_stack` field
stack :: Functor f => LensLike' f Status (NonEmpty Chained)
stack :: forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack NonEmpty Chained -> f (NonEmpty Chained)
k Status
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NonEmpty Chained
x -> Status
s { _stack :: NonEmpty Chained
_stack = NonEmpty Chained
x }) (NonEmpty Chained -> f (NonEmpty Chained)
k (Status -> NonEmpty Chained
_stack Status
s))

-- | Lens from a `Status` to its `_graph` field
graph :: Functor f => LensLike' f Status [Depends]
graph :: forall (f :: * -> *). Functor f => LensLike' f Status [Depends]
graph [Depends] -> f [Depends]
k Status
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Depends]
x -> Status
s { _graph :: [Depends]
_graph = [Depends]
x }) ([Depends] -> f [Depends]
k (Status -> [Depends]
_graph Status
s))

-- | Lens from a `Status` to its `_cache` field
cache :: Functor f => LensLike' f Status (Map Chained ImportSemantics)
cache :: forall (f :: * -> *).
Functor f =>
LensLike' f Status (Map Chained ImportSemantics)
cache Map Chained ImportSemantics -> f (Map Chained ImportSemantics)
k Status
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map Chained ImportSemantics
x -> Status
s { _cache :: Map Chained ImportSemantics
_cache = Map Chained ImportSemantics
x }) (Map Chained ImportSemantics -> f (Map Chained ImportSemantics)
k (Status -> Map Chained ImportSemantics
_cache Status
s))

-- | Lens from a `Status` to its `_remote` field
remote
    :: Functor f
    => LensLike' f Status (URL -> StateT Status IO Data.Text.Text)
remote :: forall (f :: * -> *).
Functor f =>
LensLike' f Status (URL -> StateT Status IO Text)
remote (URL -> StateT Status IO Text) -> f (URL -> StateT Status IO Text)
k Status
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\URL -> StateT Status IO Text
x -> Status
s { _remote :: URL -> StateT Status IO Text
_remote = URL -> StateT Status IO Text
x }) ((URL -> StateT Status IO Text) -> f (URL -> StateT Status IO Text)
k (Status -> URL -> StateT Status IO Text
_remote Status
s))

-- | Lens from a `Status` to its `_remote` field
remoteBytes
    :: Functor f
    => LensLike' f Status (URL -> StateT Status IO Data.ByteString.ByteString)
remoteBytes :: forall (f :: * -> *).
Functor f =>
LensLike' f Status (URL -> StateT Status IO ByteString)
remoteBytes (URL -> StateT Status IO ByteString)
-> f (URL -> StateT Status IO ByteString)
k Status
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\URL -> StateT Status IO ByteString
x -> Status
s { _remoteBytes :: URL -> StateT Status IO ByteString
_remoteBytes = URL -> StateT Status IO ByteString
x }) ((URL -> StateT Status IO ByteString)
-> f (URL -> StateT Status IO ByteString)
k (Status -> URL -> StateT Status IO ByteString
_remoteBytes Status
s))

-- | Lens from a `Status` to its `_substitutions` field
substitutions :: Functor f => LensLike' f Status (Dhall.Substitution.Substitutions Src Void)
substitutions :: forall (f :: * -> *).
Functor f =>
LensLike' f Status (Substitutions Src Void)
substitutions Substitutions Src Void -> f (Substitutions Src Void)
k Status
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Substitutions Src Void
x -> Status
s { _substitutions :: Substitutions Src Void
_substitutions = Substitutions Src Void
x }) (Substitutions Src Void -> f (Substitutions Src Void)
k (Status -> Substitutions Src Void
_substitutions Status
s))

-- | Lens from a `Status` to its `_normalizer` field
normalizer :: Functor f => LensLike' f Status (Maybe (ReifiedNormalizer Void))
normalizer :: forall (f :: * -> *).
Functor f =>
LensLike' f Status (Maybe (ReifiedNormalizer Void))
normalizer Maybe (ReifiedNormalizer Void)
-> f (Maybe (ReifiedNormalizer Void))
k Status
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (ReifiedNormalizer Void)
x -> Status
s {_normalizer :: Maybe (ReifiedNormalizer Void)
_normalizer = Maybe (ReifiedNormalizer Void)
x}) (Maybe (ReifiedNormalizer Void)
-> f (Maybe (ReifiedNormalizer Void))
k (Status -> Maybe (ReifiedNormalizer Void)
_normalizer Status
s))

-- | Lens from a `Status` to its `_startingContext` field
startingContext :: Functor f => LensLike' f Status (Context (Expr Src Void))
startingContext :: forall (f :: * -> *).
Functor f =>
LensLike' f Status (Context (Expr Src Void))
startingContext Context (Expr Src Void) -> f (Context (Expr Src Void))
k Status
s =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Context (Expr Src Void)
x -> Status
s { _startingContext :: Context (Expr Src Void)
_startingContext = Context (Expr Src Void)
x }) (Context (Expr Src Void) -> f (Context (Expr Src Void))
k (Status -> Context (Expr Src Void)
_startingContext Status
s))

-- | Lens from a `Status` to its `_cacheWarning` field
cacheWarning :: Functor f => LensLike' f Status CacheWarning
cacheWarning :: forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning CacheWarning -> f CacheWarning
k Status
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CacheWarning
x -> Status
s { _cacheWarning :: CacheWarning
_cacheWarning = CacheWarning
x }) (CacheWarning -> f CacheWarning
k (Status -> CacheWarning
_cacheWarning Status
s))

{-| This exception indicates that there was an internal error in Dhall's
    import-related logic

    This exception indicates that an invalid `Dhall.Syntax.Type` was provided to
    the `Dhall.input` function
-}
data InternalError = InternalError deriving (Typeable)


instance Show InternalError where
    show :: InternalError -> String
show InternalError
InternalError = [String] -> String
unlines
        [ String
_ERROR forall a. Semigroup a => a -> a -> a
<> String
": Compiler bug                                                        "
        , String
"                                                                                "
        , String
"Explanation: This error message means that there is a bug in the Dhall compiler."
        , String
"You didn't do anything wrong, but if you would like to see this problem fixed   "
        , String
"then you should report the bug at:                                              "
        , String
"                                                                                "
        , String
"https://github.com/dhall-lang/dhall-haskell/issues                              "
        , String
"                                                                                "
        , String
"Please include the following text in your bug report:                           "
        , String
"                                                                                "
        , String
"```                                                                             "
        , String
"Header extraction failed even though the header type-checked                    "
        , String
"```                                                                             "
        ]
      where
        _ERROR :: String
        _ERROR :: String
_ERROR = String
"\ESC[1;31mError\ESC[0m"

instance Exception InternalError

-- | Wrapper around `Network.HTTP.Client.HttpException`s with a prettier `Show`
-- instance
--
-- In order to keep the library API constant even when the @with-http@ Cabal
-- flag is disabled the pretty error message is pre-rendered and the real
-- 'Network.HTTP.Client.HttpException' is stored in a 'Dynamic'
data PrettyHttpException = PrettyHttpException String Dynamic
    deriving (Typeable)

instance Exception PrettyHttpException

instance Show PrettyHttpException where
  show :: PrettyHttpException -> String
show (PrettyHttpException String
msg Dynamic
_) = String
msg