{-# 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 Dhall.Map (Map)
import Data.Semigroup ((<>))
import Data.Text.Prettyprint.Doc (Pretty(..))
import Data.Void (Void)
import Dhall.Context (Context)
import Dhall.Core
  ( Directory (..)
  , Expr
  , File (..)
  , FilePrefix (..)
  , Import (..)
  , ImportHashed (..)
  , ImportMode (..)
  , ImportType (..)
  , ReifiedNormalizer(..)
  , URL
  )
#ifdef WITH_HTTP
import Dhall.Import.Manager (Manager)
#endif
import Dhall.Parser (Src)
import Lens.Family (LensLike')
import System.FilePath (isRelative, splitDirectories)

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

-- | 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)

-- | 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

#ifdef WITH_HTTP
    , Status -> Maybe Manager
_manager :: Maybe Manager
#else
    , _manager :: Maybe Void
#endif
    -- ^ Used to cache the `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
    }

-- | Initial `Status`, parameterised over the remote resolver, importing
--   relative to the given directory.
emptyStatusWith :: (URL -> StateT Status IO Data.Text.Text) -> FilePath -> Status
emptyStatusWith :: (URL -> StateT Status IO Text) -> FilePath -> Status
emptyStatusWith URL -> StateT Status IO Text
_remote FilePath
rootDirectory = Status :: NonEmpty Chained
-> [Depends]
-> Map Chained ImportSemantics
-> Maybe Manager
-> (URL -> StateT Status IO Text)
-> Substitutions Src Void
-> Maybe (ReifiedNormalizer Void)
-> Context (Expr Src Void)
-> SemanticCacheMode
-> Status
Status {[Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
NonEmpty Chained
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
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
_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
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remote :: URL -> StateT Status IO Text
_manager :: Maybe 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

    prefix :: FilePrefix
prefix = if FilePath -> Bool
isRelative FilePath
rootDirectory
      then FilePrefix
Here
      else FilePrefix
Absolute
    pathComponents :: [Text]
pathComponents =
        (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
Data.Text.pack ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse (FilePath -> [FilePath]
splitDirectories FilePath
rootDirectory))

    dirAsFile :: File
dirAsFile = Directory -> Text -> File
File ([Text] -> Directory
Directory [Text]
pathComponents) Text
"."

    -- Fake import to set the directory we're relative to.
    rootImport :: Import
rootImport = Import :: ImportHashed -> ImportMode -> Import
Import
      { importHashed :: ImportHashed
importHashed = ImportHashed :: Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed
        { hash :: Maybe SHA256Digest
hash = Maybe SHA256Digest
forall a. Maybe a
Nothing
        , importType :: ImportType
importType = FilePrefix -> File -> ImportType
Local FilePrefix
prefix File
dirAsFile
        }
      , importMode :: ImportMode
importMode = ImportMode
Code
      }

-- | 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))

{-| This exception indicates that there was an internal error in Dhall's
    import-related logic
    the `expected` type then the `extract` function must succeed.  If not, then
    this exception is thrown

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


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

instance Exception InternalError

-- | Wrapper around `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
-- 'HttpExcepion' is stored in a 'Dynamic'
data PrettyHttpException = PrettyHttpException String Dynamic
    deriving (Typeable)

instance Exception PrettyHttpException

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