    {-# 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.Map (Map)
    import Data.Semigroup ((<>))
    import Dhall.Binary (StandardVersion(..))
    import Dhall.Context (Context)
    import Dhall.Core
      ( Directory (..)
      , Expr
      , File (..)
      , FilePrefix (..)
      , Import (..)
      , ImportHashed (..)
      , ImportMode (..)
      , ImportType (..)
      , ReifiedNormalizer(..)
      , pretty
      )
    import Dhall.Parser (Src)
    import Dhall.TypeCheck (X)
    import Lens.Family (LensLike')
    import System.FilePath (isRelative, splitDirectories)
    import Text.Dot (Dot, NodeId, userNode, userNodeId)

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

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

        , _dot :: Dot NodeId
        -- ^ Graph of all the imports visited so far

        , _nextNodeId :: Int
        -- ^ Next node id to be used for the dot graph generation

        , _cache :: Map Import (NodeId, Expr Src X)
        -- ^ Cache of imported expressions with their node id in order to avoid
        --   importing the same expression twice with different values

        , _manager :: Maybe Dynamic
        -- ^ Cache for the HTTP `Manager` so that we only acquire it once

        , _standardVersion :: StandardVersion

        , _normalizer :: ReifiedNormalizer X

        , _startingContext :: Context (Expr Src X)

        , _resolver :: Import -> StateT (Status m) m (Expr Src Import)

        , _cacher :: Import -> Expr Src X -> StateT (Status m) m ()
        }

    -- | Default starting `Status` that is polymorphic in the base `Monad`
    emptyStatusWith
        :: (Import -> StateT (Status m) m (Expr Src Import))
        -> (Import -> Expr Src X -> StateT (Status m) m ())
        -> FilePath
        -> Status m
    emptyStatusWith _resolver _cacher rootDirectory = Status {..}
      where
        _stack = pure rootImport

        _dot = importNode (userNodeId 0) rootImport

        _nextNodeId = 1

        _cache = Map.empty

        _manager = Nothing

        _standardVersion = Dhall.Binary.defaultStandardVersion

        _normalizer = ReifiedNormalizer (const (pure Nothing))

        _startingContext = Dhall.Context.empty

        prefix = if isRelative rootDirectory
          then Here
          else Absolute
        pathComponents =
            fmap Data.Text.pack (reverse (splitDirectories rootDirectory))

        dirAsFile = File (Directory pathComponents) "."

        -- Fake import to set the directory we're relative to.
        rootImport = Import
          { importHashed = ImportHashed
            { hash = Nothing
            , importType = Local prefix dirAsFile
            }
          , importMode = Code
          }

    importNode :: NodeId -> Import -> Dot NodeId
    importNode nodeId i = do
        userNode
            nodeId
            [ ("label", Data.Text.unpack $ pretty i)
            , ("shape", "box")
            , ("style", "rounded")
            ]
        pure nodeId

    stack :: Functor f => LensLike' f (Status m) (NonEmpty Import)
    stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))

    dot :: Functor f => LensLike' f (Status m) (Dot NodeId)
    dot k s = fmap (\x -> s { _dot = x }) (k (_dot s))

    nextNodeId :: Functor f => LensLike' f (Status m) Int
    nextNodeId k s = fmap (\x -> s { _nextNodeId = x }) (k (_nextNodeId s))

    cache :: Functor f => LensLike' f (Status m) (Map Import (NodeId, Expr Src X))
    cache k s = fmap (\x -> s { _cache = x }) (k (_cache s))

    manager :: Functor f => LensLike' f (Status m) (Maybe Dynamic)
    manager k s = fmap (\x -> s { _manager = x }) (k (_manager s))

    standardVersion :: Functor f => LensLike' f (Status m) StandardVersion
    standardVersion k s =
        fmap (\x -> s { _standardVersion = x }) (k (_standardVersion s))

    normalizer :: Functor f => LensLike' f (Status m) (ReifiedNormalizer X)
    normalizer k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s))

    startingContext :: Functor f => LensLike' f (Status m) (Context (Expr Src X))
    startingContext k s =
        fmap (\x -> s { _startingContext = x }) (k (_startingContext s))

    resolver
        :: Functor f
        => LensLike' f (Status m) (Import -> StateT (Status m) m (Expr Src Import))
    resolver k s = fmap (\x -> s { _resolver = x }) (k (_resolver s))

    cacher
        :: Functor f
        => LensLike' f (Status m) (Import -> Expr Src X -> StateT (Status m) m ())
    cacher k s = fmap (\x -> s { _cacher = x }) (k (_cacher 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 = unlines
            [ _ERROR <> ": Compiler bug                                                        "
            , "                                                                                "
            , "Explanation: This error message means that there is a bug in the Dhall compiler."
            , "You didn't do anything wrong, but if you would like to see this problem fixed   "
            , "then you should report the bug at:                                              "
            , "                                                                                "
            , "https://github.com/dhall-lang/dhall-haskell/issues                              "
            , "                                                                                "
            , "Please include the following text in your bug report:                           "
            , "                                                                                "
            , "```                                                                             "
            , "Header extraction failed even though the header type-checked                    "
            , "```                                                                             "
            ]
          where
            _ERROR :: String
            _ERROR = "\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 msg _) = msg