{-# 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 (ProtocolVersion(..))
import Dhall.Context (Context)
import Dhall.Core
( Directory (..)
, Expr
, File (..)
, FilePrefix (..)
, Import (..)
, ImportHashed (..)
, ImportMode (..)
, ImportType (..)
, ReifiedNormalizer(..)
)
import Dhall.Parser (Src)
import Dhall.TypeCheck (X)
import Lens.Family (LensLike')
import System.FilePath (isRelative, splitDirectories)
import qualified Dhall.Binary
import qualified Dhall.Context
import qualified Data.Map as Map
import qualified Data.Text
data Status m = Status
{ _stack :: NonEmpty Import
, _cache :: Map Import (Expr Src X)
, _manager :: Maybe Dynamic
, _protocolVersion :: ProtocolVersion
, _normalizer :: ReifiedNormalizer X
, _startingContext :: Context (Expr Src X)
, _resolver :: Import -> StateT (Status m) m (Expr Src Import)
}
emptyStatusWith
:: (Import -> StateT (Status m) m (Expr Src Import))
-> FilePath
-> Status m
emptyStatusWith _resolver rootDirectory = Status {..}
where
_stack = pure rootImport
_cache = Map.empty
_manager = Nothing
_protocolVersion = Dhall.Binary.defaultProtocolVersion
_normalizer = ReifiedNormalizer (const 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) "."
rootImport = Import
{ importHashed = ImportHashed
{ hash = Nothing
, importType = Local prefix dirAsFile
}
, importMode = Code
}
stack :: Functor f => LensLike' f (Status m) (NonEmpty Import)
stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))
cache :: Functor f => LensLike' f (Status m) (Map Import (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))
protocolVersion :: Functor f => LensLike' f (Status m) ProtocolVersion
protocolVersion k s =
fmap (\x -> s { _protocolVersion = x }) (k (_protocolVersion 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))
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