{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
module Dhall.Import.Types where
import Control.Exception (Exception)
import Data.Dynamic
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Semigroup ((<>))
import Lens.Family (LensLike')
import System.FilePath (isRelative, splitDirectories)
import qualified Data.Map as Map
import qualified Data.Text
import Dhall.Core
( Directory (..), Expr, File (..), FilePrefix (..), Import (..)
, ImportHashed (..), ImportMode (..), ImportType (..)
)
import Dhall.Parser (Src)
import Dhall.TypeCheck (X)
data Status = Status
{ _stack :: NonEmpty Import
, _cache :: Map Import (Expr Src X)
, _manager :: Maybe Dynamic
}
emptyStatus :: FilePath -> Status
emptyStatus dir = Status (pure rootImport) Map.empty Nothing
where
prefix = if isRelative dir
then Here
else Absolute
pathComponents = fmap Data.Text.pack (reverse (splitDirectories dir))
dirAsFile = File (Directory pathComponents) "."
rootImport = Import
{ importHashed = ImportHashed
{ hash = Nothing
, importType = Local prefix dirAsFile
}
, importMode = Code
}
stack :: Functor f => LensLike' f Status (NonEmpty Import)
stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))
cache :: Functor f => LensLike' f Status (Map Import (Expr Src X))
cache k s = fmap (\x -> s { _cache = x }) (k (_cache s))
manager :: Functor f => LensLike' f Status (Maybe Dynamic)
manager k s = fmap (\x -> s { _manager = x }) (k (_manager s))
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
data PrettyHttpException = PrettyHttpException String Dynamic
deriving (Typeable)
instance Exception PrettyHttpException
instance Show PrettyHttpException where
show (PrettyHttpException msg _) = msg