{-# 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.Dynamic
import Data.List.NonEmpty               (NonEmpty)
import Data.Text.Prettyprint.Doc        (Pretty (..))
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')

#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
(Chained -> Chained -> Bool)
-> (Chained -> Chained -> Bool) -> Eq Chained
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
Eq Chained
-> (Chained -> Chained -> Ordering)
-> (Chained -> Chained -> Bool)
-> (Chained -> Chained -> Bool)
-> (Chained -> Chained -> Bool)
-> (Chained -> Chained -> Bool)
-> (Chained -> Chained -> Chained)
-> (Chained -> Chained -> Chained)
-> Ord 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
$cp1Ord :: Eq Chained
Ord)

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

-- | An import that has been fully interpeted
data 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
(SemanticCacheMode -> SemanticCacheMode -> Bool)
-> (SemanticCacheMode -> SemanticCacheMode -> Bool)
-> Eq SemanticCacheMode
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

{-| 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 -> URL -> StateT Status IO Text
_remote :: URL -> StateT Status IO Data.Text.Text
    -- ^ The remote resolver, fetches the content at the given URL.

    , 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' and the remote
--   resolver, importing relative to the given root import.
emptyStatusWith
    :: IO Manager
    -> (URL -> StateT Status IO Data.Text.Text)
    -> Import
    -> Status
emptyStatusWith :: IO Manager -> (URL -> StateT Status IO Text) -> Import -> Status
emptyStatusWith IO Manager
_newManager URL -> StateT Status IO Text
_remote Import
rootImport = Status :: NonEmpty Chained
-> [Depends]
-> Map Chained ImportSemantics
-> IO Manager
-> Maybe Manager
-> (URL -> StateT Status IO Text)
-> Substitutions Src Void
-> Maybe (ReifiedNormalizer Void)
-> Context (Expr Src Void)
-> SemanticCacheMode
-> CacheWarning
-> Status
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
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
_remote :: URL -> StateT Status IO Text
_newManager :: IO Manager
_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
..}
  where
    _stack :: NonEmpty Chained
_stack = Chained -> NonEmpty Chained
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Import -> Chained
Chained Import
rootImport)

    _graph :: [a]
_graph = []

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

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

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

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

    _startingContext :: Context a
_startingContext = Context a
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 :: LensLike' f Status (NonEmpty Chained)
stack NonEmpty Chained -> f (NonEmpty Chained)
k Status
s = (NonEmpty Chained -> Status) -> f (NonEmpty Chained) -> f Status
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 :: LensLike' f Status [Depends]
graph [Depends] -> f [Depends]
k Status
s = ([Depends] -> Status) -> f [Depends] -> f Status
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 :: LensLike' f Status (Map Chained ImportSemantics)
cache Map Chained ImportSemantics -> f (Map Chained ImportSemantics)
k Status
s = (Map Chained ImportSemantics -> Status)
-> f (Map Chained ImportSemantics) -> f Status
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 :: LensLike' f Status (URL -> StateT Status IO Text)
remote (URL -> StateT Status IO Text) -> f (URL -> StateT Status IO Text)
k Status
s = ((URL -> StateT Status IO Text) -> Status)
-> f (URL -> StateT Status IO Text) -> f Status
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 `_substitutions` field
substitutions :: Functor f => LensLike' f Status (Dhall.Substitution.Substitutions Src Void)
substitutions :: LensLike' f Status (Substitutions Src Void)
substitutions Substitutions Src Void -> f (Substitutions Src Void)
k Status
s = (Substitutions Src Void -> Status)
-> f (Substitutions Src Void) -> f Status
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 :: LensLike' f Status (Maybe (ReifiedNormalizer Void))
normalizer Maybe (ReifiedNormalizer Void)
-> f (Maybe (ReifiedNormalizer Void))
k Status
s = (Maybe (ReifiedNormalizer Void) -> Status)
-> f (Maybe (ReifiedNormalizer Void)) -> f Status
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 :: LensLike' f Status (Context (Expr Src Void))
startingContext Context (Expr Src Void) -> f (Context (Expr Src Void))
k Status
s =
    (Context (Expr Src Void) -> Status)
-> f (Context (Expr Src Void)) -> f Status
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 :: LensLike' f Status CacheWarning
cacheWarning CacheWarning -> f CacheWarning
k Status
s = (CacheWarning -> Status) -> f CacheWarning -> f Status
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 String -> ShowS
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