Remove Buildable in favor of Pretty (#459)
Fixes #40 This removes all uses of `Buildable` and replaces them with the `Pretty` class. The motivation behind this is to remove redundant code and speed up build times.
This commit is contained in:
Gabriel Gonzalez
GitHub
parent
3c051258c8
commit
c90bb69cf0
|
|
@ -169,7 +169,6 @@ Library
|
|||
directory >= 1.3 && < 1.4 ,
|
||||
exceptions >= 0.8.3 && < 0.11,
|
||||
filepath >= 1.4 && < 1.5 ,
|
||||
formatting >= 6.3 && < 6.4 ,
|
||||
haskeline >= 0.7.3.0 && < 0.8 ,
|
||||
http-client >= 0.4.30 && < 0.6 ,
|
||||
http-client-tls >= 0.2.0 && < 0.4 ,
|
||||
|
|
|
|||
|
|
@ -82,7 +82,6 @@ import Dhall.Core (Expr(..), Chunks(..))
|
|||
import Dhall.Import (Imported(..))
|
||||
import Dhall.Parser (Src(..))
|
||||
import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X)
|
||||
import Formatting.Buildable (Buildable(..))
|
||||
import GHC.Generics
|
||||
import Numeric.Natural (Natural)
|
||||
import Prelude hiding (maybe, sequence)
|
||||
|
|
@ -98,12 +97,12 @@ import qualified Data.Sequence
|
|||
import qualified Data.Set
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.Lazy
|
||||
import qualified Data.Text.Lazy.Builder
|
||||
import qualified Data.Vector
|
||||
import qualified Dhall.Context
|
||||
import qualified Dhall.Core
|
||||
import qualified Dhall.Import
|
||||
import qualified Dhall.Parser
|
||||
import qualified Dhall.Pretty.Internal
|
||||
import qualified Dhall.TypeCheck
|
||||
|
||||
-- $setup
|
||||
|
|
@ -175,11 +174,7 @@ inputWith
|
|||
inputWith (Type {..}) ctx n txt = do
|
||||
expr <- throws (Dhall.Parser.exprFromText "(input)" txt)
|
||||
expr' <- Dhall.Import.loadWithContext ctx n expr
|
||||
let suffix =
|
||||
( Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
. build
|
||||
) expected
|
||||
let suffix = Dhall.Pretty.Internal.prettyToStrictText expected
|
||||
let annot = case expr' of
|
||||
Note (Src begin end bytes) _ ->
|
||||
Note (Src begin end bytes') (Annot expr' expected)
|
||||
|
|
|
|||
|
|
@ -72,7 +72,6 @@ import Data.Text (Text)
|
|||
import Data.Text.Prettyprint.Doc (Pretty)
|
||||
import Data.Traversable
|
||||
import {-# SOURCE #-} Dhall.Pretty.Internal
|
||||
import Formatting.Buildable (Buildable(..))
|
||||
import Numeric.Natural (Natural)
|
||||
import Prelude hiding (succ)
|
||||
|
||||
|
|
@ -83,7 +82,6 @@ import qualified Data.HashSet
|
|||
import qualified Data.Sequence
|
||||
import qualified Data.Set
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
import qualified Data.Text.Prettyprint.Doc as Pretty
|
||||
|
||||
{-| Constants for a pure type system
|
||||
|
|
@ -105,9 +103,6 @@ import qualified Data.Text.Prettyprint.Doc as Pretty
|
|||
-}
|
||||
data Const = Type | Kind deriving (Show, Eq, Data, Bounded, Enum)
|
||||
|
||||
instance Buildable Const where
|
||||
build = Builder.fromText . buildConst
|
||||
|
||||
instance Pretty Const where
|
||||
pretty = Pretty.unAnnotate . prettyConst
|
||||
|
||||
|
|
@ -124,11 +119,11 @@ instance Semigroup Directory where
|
|||
Directory components₀ <> Directory components₁ =
|
||||
Directory (components₁ <> components₀)
|
||||
|
||||
instance Buildable Directory where
|
||||
build (Directory {..}) =
|
||||
foldMap buildComponent (reverse components)
|
||||
instance Pretty Directory where
|
||||
pretty (Directory {..}) =
|
||||
foldMap prettyComponent (reverse components)
|
||||
where
|
||||
buildComponent text = "/" <> build text
|
||||
prettyComponent text = "/" <> Pretty.pretty text
|
||||
|
||||
{-| A `File` is a `directory` followed by one additional path component
|
||||
representing the `file` name
|
||||
|
|
@ -138,8 +133,8 @@ data File = File
|
|||
, file :: Text
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
instance Buildable File where
|
||||
build (File {..}) = build directory <> "/" <> build file
|
||||
instance Pretty File where
|
||||
pretty (File {..}) = Pretty.pretty directory <> "/" <> Pretty.pretty file
|
||||
|
||||
instance Semigroup File where
|
||||
File directory₀ _ <> File directory₁ file =
|
||||
|
|
@ -154,10 +149,10 @@ data FilePrefix
|
|||
-- ^ Path relative to @~@
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Buildable FilePrefix where
|
||||
build Absolute = ""
|
||||
build Here = "."
|
||||
build Home = "~"
|
||||
instance Pretty FilePrefix where
|
||||
pretty Absolute = ""
|
||||
pretty Here = "."
|
||||
pretty Home = "~"
|
||||
|
||||
-- | The type of import (i.e. local vs. remote vs. environment)
|
||||
data ImportType
|
||||
|
|
@ -178,20 +173,19 @@ instance Semigroup ImportType where
|
|||
_ <> import₁ =
|
||||
import₁
|
||||
|
||||
instance Buildable ImportType where
|
||||
build (Local prefix file) =
|
||||
build prefix <> build file
|
||||
instance Pretty ImportType where
|
||||
pretty (Local prefix file) =
|
||||
Pretty.pretty prefix <> Pretty.pretty file
|
||||
|
||||
build (URL prefix file suffix headers) =
|
||||
build prefix
|
||||
<> build file
|
||||
<> build suffix
|
||||
<> foldMap buildHeaders headers
|
||||
pretty (URL prefix file suffix headers) =
|
||||
Pretty.pretty prefix
|
||||
<> Pretty.pretty file
|
||||
<> Pretty.pretty suffix
|
||||
<> foldMap prettyHeaders headers
|
||||
where
|
||||
buildHeaders h = " using " <> build h
|
||||
prettyHeaders h = " using " <> Pretty.pretty h
|
||||
|
||||
build (Env env) =
|
||||
"env:" <> build env
|
||||
pretty (Env env) = "env:" <> Pretty.pretty env
|
||||
|
||||
-- | How to interpret the import's contents (i.e. as Dhall code or raw text)
|
||||
data ImportMode = Code | RawText deriving (Eq, Ord, Show)
|
||||
|
|
@ -206,11 +200,11 @@ instance Semigroup ImportHashed where
|
|||
ImportHashed _ importType₀ <> ImportHashed hash importType₁ =
|
||||
ImportHashed hash (importType₀ <> importType₁)
|
||||
|
||||
instance Buildable ImportHashed where
|
||||
build (ImportHashed Nothing p) =
|
||||
build p
|
||||
build (ImportHashed (Just h) p) =
|
||||
build p <> "sha256:" <> build (show h) <> " "
|
||||
instance Pretty ImportHashed where
|
||||
pretty (ImportHashed Nothing p) =
|
||||
Pretty.pretty p
|
||||
pretty (ImportHashed (Just h) p) =
|
||||
Pretty.pretty p <> "sha256:" <> Pretty.pretty (show h) <> " "
|
||||
|
||||
-- | Reference to an external resource
|
||||
data Import = Import
|
||||
|
|
@ -222,16 +216,14 @@ instance Semigroup Import where
|
|||
Import importHashed₀ _ <> Import importHashed₁ code =
|
||||
Import (importHashed₀ <> importHashed₁) code
|
||||
|
||||
instance Buildable Import where
|
||||
build (Import {..}) = build importHashed <> suffix
|
||||
instance Pretty Import where
|
||||
pretty (Import {..}) = Pretty.pretty importHashed <> Pretty.pretty suffix
|
||||
where
|
||||
suffix :: Text
|
||||
suffix = case importMode of
|
||||
RawText -> "as Text"
|
||||
Code -> ""
|
||||
|
||||
instance Pretty Import where
|
||||
pretty import_ = Pretty.pretty (Builder.toLazyText (build import_))
|
||||
|
||||
-- | Type synonym for `Import`, provided for backwards compatibility
|
||||
type Path = Import
|
||||
|
||||
|
|
@ -275,8 +267,8 @@ data Var = V Text !Integer
|
|||
instance IsString Var where
|
||||
fromString str = V (fromString str) 0
|
||||
|
||||
instance Buildable Var where
|
||||
build = Builder.fromText . buildVar
|
||||
instance Pretty Var where
|
||||
pretty = Pretty.unAnnotate . prettyVar
|
||||
|
||||
-- | Syntax tree for expressions
|
||||
data Expr s a
|
||||
|
|
@ -580,9 +572,6 @@ instance IsString (Chunks s a) where
|
|||
-}
|
||||
|
||||
-- | Generates a syntactically valid Dhall program
|
||||
instance Buildable a => Buildable (Expr s a) where
|
||||
build = Builder.fromText . buildExpr
|
||||
|
||||
instance Pretty a => Pretty (Expr s a) where
|
||||
pretty = Pretty.unAnnotate . prettyExpr
|
||||
|
||||
|
|
@ -1376,12 +1365,12 @@ normalizeWith ctx e0 = loop (denote e0)
|
|||
App NaturalOdd (NaturalLit n) -> BoolLit (odd n)
|
||||
App NaturalToInteger (NaturalLit n) -> IntegerLit (toInteger n)
|
||||
App NaturalShow (NaturalLit n) ->
|
||||
TextLit (Chunks [] (buildNatural n))
|
||||
TextLit (Chunks [] (Data.Text.pack (show n)))
|
||||
App IntegerShow (IntegerLit n)
|
||||
| 0 <= n -> TextLit (Chunks [] ("+" <> buildNumber n))
|
||||
| otherwise -> TextLit (Chunks [] (buildNumber n))
|
||||
| 0 <= n -> TextLit (Chunks [] ("+" <> Data.Text.pack (show n)))
|
||||
| otherwise -> TextLit (Chunks [] (Data.Text.pack (show n)))
|
||||
App DoubleShow (DoubleLit n) ->
|
||||
TextLit (Chunks [] (buildScientific n))
|
||||
TextLit (Chunks [] (Data.Text.pack (show n)))
|
||||
App (App OptionalBuild _A₀) g ->
|
||||
loop (App (App (App g optional) just) nothing)
|
||||
where
|
||||
|
|
|
|||
|
|
@ -127,13 +127,11 @@ import Data.List.NonEmpty (NonEmpty(..))
|
|||
import Data.Map (Map)
|
||||
import Data.Semigroup (sconcat, (<>))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Lazy.Builder (Builder)
|
||||
#if MIN_VERSION_base(4,8,0)
|
||||
#else
|
||||
import Data.Traversable (traverse)
|
||||
#endif
|
||||
import Data.Typeable (Typeable)
|
||||
import Formatting.Buildable (build)
|
||||
import System.FilePath ((</>))
|
||||
import Dhall.Core
|
||||
( Expr(..)
|
||||
|
|
@ -146,6 +144,7 @@ import Dhall.Core
|
|||
, ImportMode(..)
|
||||
, Import(..)
|
||||
)
|
||||
|
||||
import Dhall.Parser (Parser(..), ParseError(..), Src(..))
|
||||
import Dhall.TypeCheck (X(..))
|
||||
import Lens.Family (LensLike')
|
||||
|
|
@ -157,35 +156,32 @@ import Network.HTTP.Client
|
|||
import Network.HTTP.Client (HttpException(..), Manager)
|
||||
#endif
|
||||
|
||||
import qualified Control.Monad.Trans.State.Strict as State
|
||||
import qualified Control.Monad.Trans.State.Strict as State
|
||||
import qualified Crypto.Hash
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.CaseInsensitive
|
||||
import qualified Data.Foldable
|
||||
import qualified Data.List as List
|
||||
import qualified Data.List as List
|
||||
import qualified Data.HashMap.Strict.InsOrd
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
import qualified Data.Text.Lazy.Encoding
|
||||
import qualified Data.Text.IO
|
||||
import qualified Dhall.Core
|
||||
import qualified Dhall.Parser
|
||||
import qualified Dhall.Context
|
||||
import qualified Dhall.Pretty.Internal
|
||||
import qualified Dhall.TypeCheck
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import qualified Network.HTTP.Client.TLS as HTTP
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import qualified Network.HTTP.Client.TLS as HTTP
|
||||
import qualified System.Environment
|
||||
import qualified System.Directory
|
||||
import qualified Text.Megaparsec
|
||||
import qualified Text.Parser.Combinators
|
||||
import qualified Text.Parser.Token
|
||||
|
||||
builderToString :: Builder -> String
|
||||
builderToString = Data.Text.Lazy.unpack . Builder.toLazyText
|
||||
|
||||
-- | An import failed because of a cycle in the import graph
|
||||
newtype Cycle = Cycle
|
||||
{ cyclicImport :: Import -- ^ The offending cyclic import
|
||||
|
|
@ -196,7 +192,7 @@ instance Exception Cycle
|
|||
|
||||
instance Show Cycle where
|
||||
show (Cycle import_) =
|
||||
"\nCyclic import: " ++ builderToString (build import_)
|
||||
"\nCyclic import: " ++ Dhall.Pretty.Internal.prettyToString import_
|
||||
|
||||
{-| Dhall tries to ensure that all expressions hosted on network endpoints are
|
||||
weakly referentially transparent, meaning roughly that any two clients will
|
||||
|
|
@ -232,7 +228,7 @@ instance Exception ReferentiallyOpaque
|
|||
|
||||
instance Show ReferentiallyOpaque where
|
||||
show (ReferentiallyOpaque import_) =
|
||||
"\nReferentially opaque import: " ++ builderToString (build import_)
|
||||
"\nReferentially opaque import: " ++ Dhall.Pretty.Internal.prettyToString import_
|
||||
|
||||
-- | Extend another exception with the current import stack
|
||||
data Imported e = Imported
|
||||
|
|
@ -249,7 +245,7 @@ instance Show e => Show (Imported e) where
|
|||
++ show e
|
||||
where
|
||||
indent (n, import_) =
|
||||
take (2 * n) (repeat ' ') ++ "↳ " ++ builderToString (build import_)
|
||||
take (2 * n) (repeat ' ') ++ "↳ " ++ Dhall.Pretty.Internal.prettyToString import_
|
||||
-- Canonicalize all imports
|
||||
imports' = zip [0..] (drop 1 (reverse (canonicalizeAll imports)))
|
||||
|
||||
|
|
@ -546,7 +542,7 @@ exprFromImport (Import {..}) = do
|
|||
URL prefix file suffix maybeHeaders -> do
|
||||
m <- needManager
|
||||
|
||||
let fileText = Data.Text.Lazy.toStrict $ Builder.toLazyText (build file)
|
||||
let fileText = Dhall.Pretty.Internal.prettyToStrictText file
|
||||
let url = Text.unpack (prefix <> fileText <> suffix)
|
||||
|
||||
request <- liftIO (HTTP.parseUrlThrow url)
|
||||
|
|
@ -568,11 +564,7 @@ exprFromImport (Import {..}) = do
|
|||
[("header", Text), ("value", Text)]
|
||||
)
|
||||
)
|
||||
let suffix_ =
|
||||
( Data.Text.Lazy.toStrict
|
||||
. Builder.toLazyText
|
||||
. build
|
||||
) expected
|
||||
let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected
|
||||
let annot = case expr of
|
||||
Note (Src begin end bytes) _ ->
|
||||
Note (Src begin end bytes') (Annot expr expected)
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@ import Data.Sequence (ViewL (..))
|
|||
import Data.Set (Set)
|
||||
import Data.String (IsString (..))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Prettyprint.Doc (Pretty (..))
|
||||
import Data.Void (Void)
|
||||
import Formatting.Buildable (Buildable (..))
|
||||
import Prelude hiding (const, pi)
|
||||
import Text.Parser.Combinators (try, (<?>))
|
||||
import Text.Parser.Token (TokenParsing (..))
|
||||
|
|
@ -37,11 +37,11 @@ import qualified Text.Parser.Token.Style
|
|||
data Src = Src Text.Megaparsec.SourcePos Text.Megaparsec.SourcePos Text
|
||||
deriving (Data, Eq, Show)
|
||||
|
||||
instance Buildable Src where
|
||||
build (Src begin _ text) =
|
||||
build text <> "\n"
|
||||
instance Pretty Src where
|
||||
pretty (Src begin _ text) =
|
||||
pretty text <> "\n"
|
||||
<> "\n"
|
||||
<> build (Text.Megaparsec.sourcePosPretty begin)
|
||||
<> pretty (Text.Megaparsec.sourcePosPretty begin)
|
||||
<> "\n"
|
||||
|
||||
{-| A `Parser` that is almost identical to
|
||||
|
|
|
|||
|
|
@ -787,23 +787,23 @@ import_ = (do
|
|||
_Text
|
||||
return RawText
|
||||
|
||||
-- | Similar to `Dhall.Core.buildChunks` except that this doesn't bother to
|
||||
-- | Similar to `Dhall.Core.renderChunks` except that this doesn't bother to
|
||||
-- render interpolated expressions to avoid a `Buildable a` constraint. The
|
||||
-- interpolated contents are not necessary for computing how much to dedent a
|
||||
-- multi-line string
|
||||
--
|
||||
-- This also doesn't include the surrounding quotes since they would interfere
|
||||
-- with the whitespace detection
|
||||
buildChunks :: Chunks s a -> Text
|
||||
buildChunks (Chunks a b) = foldMap buildChunk a <> escapeText b
|
||||
renderChunks :: Chunks s a -> Text
|
||||
renderChunks (Chunks a b) = foldMap renderChunk a <> escapeText b
|
||||
where
|
||||
buildChunk :: (Text, Expr s a) -> Text
|
||||
buildChunk (c, _) = escapeText c <> "${x}"
|
||||
renderChunk :: (Text, Expr s a) -> Text
|
||||
renderChunk (c, _) = escapeText c <> "${x}"
|
||||
|
||||
dedent :: Chunks Src a -> Chunks Src a
|
||||
dedent chunks0 = process chunks0
|
||||
where
|
||||
text0 = buildChunks chunks0
|
||||
text0 = renderChunks chunks0
|
||||
|
||||
lines0 = Data.Text.lines text0
|
||||
|
||||
|
|
|
|||
|
|
@ -10,12 +10,7 @@ module Dhall.Pretty.Internal (
|
|||
Ann(..)
|
||||
, annToAnsiStyle
|
||||
, prettyExpr
|
||||
, buildConst
|
||||
, buildVar
|
||||
, buildExpr
|
||||
, buildNatural
|
||||
, buildNumber
|
||||
, buildScientific
|
||||
, prettyVar
|
||||
, pretty
|
||||
, escapeText
|
||||
|
||||
|
|
@ -25,6 +20,10 @@ module Dhall.Pretty.Internal (
|
|||
, prettyNatural
|
||||
, prettyNumber
|
||||
, prettyScientific
|
||||
, prettyToStrictText
|
||||
, prettyToString
|
||||
|
||||
, docToStrictText
|
||||
|
||||
, builtin
|
||||
, keyword
|
||||
|
|
@ -63,7 +62,6 @@ import Data.Scientific (Scientific)
|
|||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Prettyprint.Doc (Doc, Pretty, space)
|
||||
import Formatting.Buildable (Buildable(..))
|
||||
import Numeric.Natural (Natural)
|
||||
import Prelude hiding (succ)
|
||||
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal
|
||||
|
|
@ -73,11 +71,10 @@ import qualified Data.HashMap.Strict.InsOrd
|
|||
import qualified Data.HashSet
|
||||
import qualified Data.List
|
||||
import qualified Data.Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
import qualified Data.Text.Prettyprint.Doc as Pretty
|
||||
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Prettyprint.Doc as Pretty
|
||||
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
|
||||
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
|
||||
|
||||
{-| Annotation type used to tag elements in a pretty-printed document for
|
||||
syntax highlighting purposes
|
||||
|
|
@ -826,33 +823,6 @@ pretty = Pretty.renderStrict . Pretty.layoutPretty options . Pretty.pretty
|
|||
where
|
||||
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
|
||||
|
||||
-- | Text corresponding to the @label@ token in "Dhall.Parser"
|
||||
buildLabel :: Text -> Text
|
||||
buildLabel l = case Text.uncons l of
|
||||
Just (h, t)
|
||||
| headCharacter h && Text.all tailCharacter t && not (Data.HashSet.member l reservedIdentifiers)
|
||||
-> l
|
||||
_ -> "`" <> l <> "`"
|
||||
|
||||
|
||||
-- | Text corresponding to the @number@ token in "Dhall.Parser"
|
||||
buildNumber :: Integer -> Text
|
||||
buildNumber = Text.pack . show
|
||||
|
||||
-- | Text corresponding to the @natural@ token in "Dhall.Parser"
|
||||
buildNatural :: Natural -> Text
|
||||
buildNatural = Text.pack . show
|
||||
|
||||
-- | Text corresponding to the @double@ token in "Dhall.Parser"
|
||||
buildScientific :: Scientific -> Text
|
||||
buildScientific = Text.pack . show
|
||||
|
||||
-- | Text corresponding to the @text@ token in "Dhall.Parser"
|
||||
buildChunks :: Buildable a => Chunks s a -> Text
|
||||
buildChunks (Chunks a b) = "\"" <> foldMap buildChunk a <> escapeText b <> "\""
|
||||
where
|
||||
buildChunk (c, d) = escapeText c <> "${" <> buildExprA d <> "}"
|
||||
|
||||
-- | Escape a `Text` literal using Dhall's escaping rules for single-quoted
|
||||
-- @Text@
|
||||
escapeSingleQuotedText :: Text -> Text
|
||||
|
|
@ -899,329 +869,16 @@ escapeText text = Text.concatMap adapt text
|
|||
| n < 10 = Data.Char.chr (Data.Char.ord '0' + n)
|
||||
| otherwise = Data.Char.chr (Data.Char.ord 'A' + n - 10)
|
||||
|
||||
-- | Text corresponding to the @expr@ parser in "Dhall.Parser"
|
||||
buildExpr :: Buildable a => Expr s a -> Text
|
||||
buildExpr = buildExprA
|
||||
prettyToString :: Pretty a => a -> String
|
||||
prettyToString =
|
||||
Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty
|
||||
where
|
||||
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
|
||||
|
||||
-- | Text corresponding to the @exprA@ parser in "Dhall.Parser"
|
||||
buildExprA :: Buildable a => Expr s a -> Text
|
||||
buildExprA (Annot a b) = buildExprB a <> " : " <> buildExprA b
|
||||
buildExprA (Note _ b) = buildExprA b
|
||||
buildExprA a = buildExprB a
|
||||
docToStrictText :: Doc ann -> Text.Text
|
||||
docToStrictText = Pretty.renderStrict . Pretty.layoutPretty options
|
||||
where
|
||||
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
|
||||
|
||||
-- | Text corresponding to the @exprB@ parser in "Dhall.Parser"
|
||||
buildExprB :: Buildable a => Expr s a -> Text
|
||||
buildExprB (Lam a b c) =
|
||||
"λ("
|
||||
<> buildLabel a
|
||||
<> " : "
|
||||
<> buildExprA b
|
||||
<> ") → "
|
||||
<> buildExprB c
|
||||
buildExprB (BoolIf a b c) =
|
||||
"if "
|
||||
<> buildExprA a
|
||||
<> " then "
|
||||
<> buildExprA b
|
||||
<> " else "
|
||||
<> buildExprA c
|
||||
buildExprB (Pi "_" b c) =
|
||||
buildExprC b
|
||||
<> " → "
|
||||
<> buildExprB c
|
||||
buildExprB (Pi a b c) =
|
||||
"∀("
|
||||
<> buildLabel a
|
||||
<> " : "
|
||||
<> buildExprA b
|
||||
<> ") → "
|
||||
<> buildExprB c
|
||||
buildExprB (Let a Nothing c d) =
|
||||
"let "
|
||||
<> buildLabel a
|
||||
<> " = "
|
||||
<> buildExprA c
|
||||
<> " in "
|
||||
<> buildExprB d
|
||||
buildExprB (Let a (Just b) c d) =
|
||||
"let "
|
||||
<> buildLabel a
|
||||
<> " : "
|
||||
<> buildExprA b
|
||||
<> " = "
|
||||
<> buildExprA c
|
||||
<> " in "
|
||||
<> buildExprB d
|
||||
buildExprB (ListLit Nothing b) =
|
||||
"[" <> buildElems (Data.Foldable.toList b) <> "]"
|
||||
buildExprB (ListLit (Just a) b) =
|
||||
"[" <> buildElems (Data.Foldable.toList b) <> "] : List " <> buildExprE a
|
||||
buildExprB (OptionalLit a b) =
|
||||
"[" <> buildElems (Data.Foldable.toList b) <> "] : Optional " <> buildExprE a
|
||||
buildExprB (Merge a b (Just c)) =
|
||||
"merge " <> buildExprE a <> " " <> buildExprE b <> " : " <> buildExprD c
|
||||
buildExprB (Merge a b Nothing) =
|
||||
"merge " <> buildExprE a <> " " <> buildExprE b
|
||||
buildExprB (Note _ b) =
|
||||
buildExprB b
|
||||
buildExprB a =
|
||||
buildExprC a
|
||||
|
||||
-- | Text corresponding to the @exprC@ parser in "Dhall.Parser"
|
||||
buildExprC :: Buildable a => Expr s a -> Text
|
||||
buildExprC = buildExprC0
|
||||
|
||||
-- | Text corresponding to the @exprC0@ parser in "Dhall.Parser"
|
||||
buildExprC0 :: Buildable a => Expr s a -> Text
|
||||
buildExprC0 (BoolOr a b) = buildExprC1 a <> " || " <> buildExprC0 b
|
||||
buildExprC0 (Note _ b) = buildExprC0 b
|
||||
buildExprC0 a = buildExprC1 a
|
||||
|
||||
-- | Text corresponding to the @exprC1@ parser in "Dhall.Parser"
|
||||
buildExprC1 :: Buildable a => Expr s a -> Text
|
||||
buildExprC1 (TextAppend a b) = buildExprC2 a <> " ++ " <> buildExprC1 b
|
||||
buildExprC1 (Note _ b) = buildExprC1 b
|
||||
buildExprC1 a = buildExprC2 a
|
||||
|
||||
-- | Text corresponding to the @exprC2@ parser in "Dhall.Parser"
|
||||
buildExprC2 :: Buildable a => Expr s a -> Text
|
||||
buildExprC2 (NaturalPlus a b) = buildExprC3 a <> " + " <> buildExprC2 b
|
||||
buildExprC2 (Note _ b) = buildExprC2 b
|
||||
buildExprC2 a = buildExprC3 a
|
||||
|
||||
-- | Text corresponding to the @exprC3@ parser in "Dhall.Parser"
|
||||
buildExprC3 :: Buildable a => Expr s a -> Text
|
||||
buildExprC3 (ListAppend a b) = buildExprC4 a <> " # " <> buildExprC3 b
|
||||
buildExprC3 (Note _ b) = buildExprC3 b
|
||||
buildExprC3 a = buildExprC4 a
|
||||
|
||||
-- | Text corresponding to the @exprC4@ parser in "Dhall.Parser"
|
||||
buildExprC4 :: Buildable a => Expr s a -> Text
|
||||
buildExprC4 (BoolAnd a b) = buildExprC5 a <> " && " <> buildExprC4 b
|
||||
buildExprC4 (Note _ b) = buildExprC4 b
|
||||
buildExprC4 a = buildExprC5 a
|
||||
|
||||
-- | Text corresponding to the @exprC5@ parser in "Dhall.Parser"
|
||||
buildExprC5 :: Buildable a => Expr s a -> Text
|
||||
buildExprC5 (Combine a b) = buildExprC6 a <> " ∧ " <> buildExprC5 b
|
||||
buildExprC5 (Note _ b) = buildExprC5 b
|
||||
buildExprC5 a = buildExprC6 a
|
||||
|
||||
-- | Text corresponding to the @exprC6@ parser in "Dhall.Parser"
|
||||
buildExprC6 :: Buildable a => Expr s a -> Text
|
||||
buildExprC6 (Prefer a b) = buildExprC7 a <> " ⫽ " <> buildExprC6 b
|
||||
buildExprC6 (Note _ b) = buildExprC6 b
|
||||
buildExprC6 a = buildExprC7 a
|
||||
|
||||
-- | Text corresponding to the @exprC7@ parser in "Dhall.Parser"
|
||||
buildExprC7 :: Buildable a => Expr s a -> Text
|
||||
buildExprC7 (CombineTypes a b) = buildExprC8 a <> " ⩓ " <> buildExprC7 b
|
||||
buildExprC7 (Note _ b) = buildExprC7 b
|
||||
buildExprC7 a = buildExprC8 a
|
||||
|
||||
-- | Text corresponding to the @exprC8@ parser in "Dhall.Parser"
|
||||
buildExprC8 :: Buildable a => Expr s a -> Text
|
||||
buildExprC8 (NaturalTimes a b) = buildExprC9 a <> " * " <> buildExprC8 b
|
||||
buildExprC8 (Note _ b) = buildExprC8 b
|
||||
buildExprC8 a = buildExprC9 a
|
||||
|
||||
-- | Text corresponding to the @exprC9@ parser in "Dhall.Parser"
|
||||
buildExprC9 :: Buildable a => Expr s a -> Text
|
||||
buildExprC9 (BoolEQ a b) = buildExprC10 a <> " == " <> buildExprC9 b
|
||||
buildExprC9 (Note _ b) = buildExprC9 b
|
||||
buildExprC9 a = buildExprC10 a
|
||||
|
||||
-- | Text corresponding to the @exprC10@ parser in "Dhall.Parser"
|
||||
buildExprC10 :: Buildable a => Expr s a -> Text
|
||||
buildExprC10 (BoolNE a b) = buildExprD a <> " != " <> buildExprC10 b
|
||||
buildExprC10 (Note _ b) = buildExprC10 b
|
||||
buildExprC10 a = buildExprD a
|
||||
|
||||
-- | Text corresponding to the @exprD@ parser in "Dhall.Parser"
|
||||
buildExprD :: Buildable a => Expr s a -> Text
|
||||
buildExprD (App a b) = buildExprD a <> " " <> buildExprE b
|
||||
buildExprD (Constructors b) = "constructors " <> buildExprE b
|
||||
buildExprD (Note _ b) = buildExprD b
|
||||
buildExprD a = buildExprE a
|
||||
|
||||
-- | Text corresponding to the @exprE@ parser in "Dhall.Parser"
|
||||
buildExprE :: Buildable a => Expr s a -> Text
|
||||
buildExprE (Field a b) = buildExprE a <> "." <> buildLabel b
|
||||
buildExprE (Note _ b) = buildExprE b
|
||||
buildExprE a = buildExprF a
|
||||
|
||||
-- | Text corresponding to the @exprF@ parser in "Dhall.Parser"
|
||||
buildExprF :: Buildable a => Expr s a -> Text
|
||||
buildExprF (Var a) =
|
||||
buildVar a
|
||||
buildExprF (Const k) =
|
||||
buildConst k
|
||||
buildExprF Bool =
|
||||
"Bool"
|
||||
buildExprF Natural =
|
||||
"Natural"
|
||||
buildExprF NaturalFold =
|
||||
"Natural/fold"
|
||||
buildExprF NaturalBuild =
|
||||
"Natural/build"
|
||||
buildExprF NaturalIsZero =
|
||||
"Natural/isZero"
|
||||
buildExprF NaturalEven =
|
||||
"Natural/even"
|
||||
buildExprF NaturalOdd =
|
||||
"Natural/odd"
|
||||
buildExprF NaturalToInteger =
|
||||
"Natural/toInteger"
|
||||
buildExprF NaturalShow =
|
||||
"Natural/show"
|
||||
buildExprF Integer =
|
||||
"Integer"
|
||||
buildExprF IntegerShow =
|
||||
"Integer/show"
|
||||
buildExprF Double =
|
||||
"Double"
|
||||
buildExprF DoubleShow =
|
||||
"Double/show"
|
||||
buildExprF Text =
|
||||
"Text"
|
||||
buildExprF List =
|
||||
"List"
|
||||
buildExprF ListBuild =
|
||||
"List/build"
|
||||
buildExprF ListFold =
|
||||
"List/fold"
|
||||
buildExprF ListLength =
|
||||
"List/length"
|
||||
buildExprF ListHead =
|
||||
"List/head"
|
||||
buildExprF ListLast =
|
||||
"List/last"
|
||||
buildExprF ListIndexed =
|
||||
"List/indexed"
|
||||
buildExprF ListReverse =
|
||||
"List/reverse"
|
||||
buildExprF Optional =
|
||||
"Optional"
|
||||
buildExprF OptionalFold =
|
||||
"Optional/fold"
|
||||
buildExprF OptionalBuild =
|
||||
"Optional/build"
|
||||
buildExprF (BoolLit True) =
|
||||
"True"
|
||||
buildExprF (BoolLit False) =
|
||||
"False"
|
||||
buildExprF (IntegerLit a)
|
||||
| 0 <= a = "+" <> buildNumber a
|
||||
| otherwise = buildNumber a
|
||||
buildExprF (NaturalLit a) =
|
||||
buildNatural a
|
||||
buildExprF (DoubleLit a) =
|
||||
buildScientific a
|
||||
buildExprF (TextLit a) =
|
||||
buildChunks a
|
||||
buildExprF (Record a) =
|
||||
buildRecord a
|
||||
buildExprF (RecordLit a) =
|
||||
buildRecordLit a
|
||||
buildExprF (Union a) =
|
||||
buildUnion a
|
||||
buildExprF (UnionLit a b c) =
|
||||
buildUnionLit a b c
|
||||
buildExprF (ListLit Nothing b) =
|
||||
"[" <> buildElems (Data.Foldable.toList b) <> "]"
|
||||
buildExprF (Embed a) =
|
||||
Data.Text.Lazy.toStrict . Builder.toLazyText $ build a
|
||||
buildExprF (Note _ b) =
|
||||
buildExprF b
|
||||
buildExprF a =
|
||||
"(" <> buildExprA a <> ")"
|
||||
|
||||
-- | Text corresponding to the @const@ parser in "Dhall.Parser"
|
||||
buildConst :: Const -> Text
|
||||
buildConst Type = "Type"
|
||||
buildConst Kind = "Kind"
|
||||
|
||||
-- | Text corresponding to the @var@ parser in "Dhall.Parser"
|
||||
buildVar :: Var -> Text
|
||||
buildVar (V x 0) = buildLabel x
|
||||
buildVar (V x n) = buildLabel x <> "@" <> buildNumber n
|
||||
|
||||
-- | Text corresponding to the @elems@ parser in "Dhall.Parser"
|
||||
buildElems :: Buildable a => [Expr s a] -> Text
|
||||
buildElems [] = ""
|
||||
buildElems [a] = buildExprA a
|
||||
buildElems (a:bs) = buildExprA a <> ", " <> buildElems bs
|
||||
|
||||
-- | Text corresponding to the @recordLit@ parser in "Dhall.Parser"
|
||||
buildRecordLit :: Buildable a => InsOrdHashMap Text (Expr s a) -> Text
|
||||
buildRecordLit a | Data.HashMap.Strict.InsOrd.null a =
|
||||
"{=}"
|
||||
buildRecordLit a =
|
||||
"{ " <> buildFieldValues (Data.HashMap.Strict.InsOrd.toList a) <> " }"
|
||||
|
||||
-- | Text corresponding to the @fieldValues@ parser in "Dhall.Parser"
|
||||
buildFieldValues :: Buildable a => [(Text, Expr s a)] -> Text
|
||||
buildFieldValues [] = ""
|
||||
buildFieldValues [a] = buildFieldValue a
|
||||
buildFieldValues (a:bs) = buildFieldValue a <> ", " <> buildFieldValues bs
|
||||
|
||||
-- | Text corresponding to the @fieldValue@ parser in "Dhall.Parser"
|
||||
buildFieldValue :: Buildable a => (Text, Expr s a) -> Text
|
||||
buildFieldValue (a, b) = buildLabel a <> " = " <> buildExprA b
|
||||
|
||||
-- | Text corresponding to the @record@ parser in "Dhall.Parser"
|
||||
buildRecord :: Buildable a => InsOrdHashMap Text (Expr s a) -> Text
|
||||
buildRecord a | Data.HashMap.Strict.InsOrd.null a =
|
||||
"{}"
|
||||
buildRecord a =
|
||||
"{ " <> buildFieldTypes (Data.HashMap.Strict.InsOrd.toList a) <> " }"
|
||||
|
||||
-- | Text corresponding to the @fieldTypes@ parser in "Dhall.Parser"
|
||||
buildFieldTypes :: Buildable a => [(Text, Expr s a)] -> Text
|
||||
buildFieldTypes [] = ""
|
||||
buildFieldTypes [a] = buildFieldType a
|
||||
buildFieldTypes (a:bs) = buildFieldType a <> ", " <> buildFieldTypes bs
|
||||
|
||||
-- | Text corresponding to the @fieldType@ parser in "Dhall.Parser"
|
||||
buildFieldType :: Buildable a => (Text, Expr s a) -> Text
|
||||
buildFieldType (a, b) = buildLabel a <> " : " <> buildExprA b
|
||||
|
||||
-- | Text corresponding to the @union@ parser in "Dhall.Parser"
|
||||
buildUnion :: Buildable a => InsOrdHashMap Text (Expr s a) -> Text
|
||||
buildUnion a | Data.HashMap.Strict.InsOrd.null a =
|
||||
"<>"
|
||||
buildUnion a =
|
||||
"< " <> buildAlternativeTypes (Data.HashMap.Strict.InsOrd.toList a) <> " >"
|
||||
|
||||
-- | Text corresponding to the @alternativeTypes@ parser in "Dhall.Parser"
|
||||
buildAlternativeTypes :: Buildable a => [(Text, Expr s a)] -> Text
|
||||
buildAlternativeTypes [] =
|
||||
""
|
||||
buildAlternativeTypes [a] =
|
||||
buildAlternativeType a
|
||||
buildAlternativeTypes (a:bs) =
|
||||
buildAlternativeType a <> " | " <> buildAlternativeTypes bs
|
||||
|
||||
-- | Text corresponding to the @alternativeType@ parser in "Dhall.Parser"
|
||||
buildAlternativeType :: Buildable a => (Text, Expr s a) -> Text
|
||||
buildAlternativeType (a, b) = buildLabel a <> " : " <> buildExprA b
|
||||
|
||||
-- | Text corresponding to the @unionLit@ parser in "Dhall.Parser"
|
||||
buildUnionLit
|
||||
:: Buildable a
|
||||
=> Text -> Expr s a -> InsOrdHashMap Text (Expr s a) -> Text
|
||||
buildUnionLit a b c
|
||||
| Data.HashMap.Strict.InsOrd.null c =
|
||||
"< "
|
||||
<> buildLabel a
|
||||
<> " = "
|
||||
<> buildExprA b
|
||||
<> " >"
|
||||
| otherwise =
|
||||
"< "
|
||||
<> buildLabel a
|
||||
<> " = "
|
||||
<> buildExprA b
|
||||
<> " | "
|
||||
<> buildAlternativeTypes (Data.HashMap.Strict.InsOrd.toList c)
|
||||
<> " >"
|
||||
prettyToStrictText :: Pretty a => a -> Text.Text
|
||||
prettyToStrictText = docToStrictText . Pretty.pretty
|
||||
|
|
|
|||
|
|
@ -1,32 +1,18 @@
|
|||
module Dhall.Pretty.Internal where
|
||||
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Prettyprint.Doc (Pretty, Doc)
|
||||
import Formatting.Buildable (Buildable(..))
|
||||
import Numeric.Natural (Natural)
|
||||
import Prelude
|
||||
|
||||
import {-# SOURCE #-} Dhall.Core
|
||||
|
||||
data Ann
|
||||
|
||||
buildConst :: Const -> Text
|
||||
|
||||
buildVar :: Var -> Text
|
||||
|
||||
buildExpr :: Buildable a => Expr s a -> Text
|
||||
prettyVar :: Var -> Doc Ann
|
||||
|
||||
prettyConst :: Const -> Doc Ann
|
||||
|
||||
prettyExpr :: Pretty a => Expr s a -> Doc Ann
|
||||
|
||||
buildNatural :: Natural -> Text
|
||||
|
||||
buildNumber :: Integer -> Text
|
||||
|
||||
buildScientific :: Scientific -> Text
|
||||
|
||||
pretty :: Pretty a => a -> Text
|
||||
|
||||
escapeText :: Text -> Text
|
||||
|
|
|
|||
|
|
@ -28,44 +28,34 @@ import Data.Monoid ((<>))
|
|||
import Data.Sequence (Seq, ViewL(..))
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Lazy.Builder (Builder)
|
||||
import Data.Text.Prettyprint.Doc (Doc, Pretty(..))
|
||||
import Data.Traversable (forM)
|
||||
import Data.Typeable (Typeable)
|
||||
import Dhall.Core (Const(..), Chunks(..), Expr(..), Var(..))
|
||||
import Dhall.Context (Context)
|
||||
import Formatting.Buildable (Buildable(..))
|
||||
import Dhall.Pretty (Ann)
|
||||
|
||||
import qualified Data.Foldable
|
||||
import qualified Data.HashMap.Strict
|
||||
import qualified Data.HashMap.Strict.InsOrd
|
||||
import qualified Data.Sequence
|
||||
import qualified Data.Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
import qualified Data.Text.Prettyprint.Doc as Pretty
|
||||
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Prettyprint.Doc as Pretty
|
||||
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
|
||||
import qualified Dhall.Context
|
||||
import qualified Dhall.Core
|
||||
import qualified Dhall.Diff
|
||||
import qualified Dhall.Pretty
|
||||
import qualified Dhall.Pretty.Internal
|
||||
|
||||
traverseWithIndex_ :: Applicative f => (Int -> a -> f b) -> Seq a -> f ()
|
||||
traverseWithIndex_ k xs =
|
||||
Data.Foldable.sequenceA_ (Data.Sequence.mapWithIndex k xs)
|
||||
|
||||
docToLazyText :: Doc a -> Text
|
||||
docToLazyText = Pretty.renderStrict . Pretty.layoutPretty opts
|
||||
where
|
||||
opts = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
|
||||
|
||||
axiom :: Const -> Either (TypeError s a) Const
|
||||
axiom Type = return Kind
|
||||
axiom Kind = Left (TypeError Dhall.Context.empty (Const Kind) Untyped)
|
||||
|
||||
|
||||
rule :: Const -> Const -> Either () Const
|
||||
-- This forbids dependent types. If this ever changes, then the fast
|
||||
-- path in the Let case of typeWithA will become unsound.
|
||||
|
|
@ -739,7 +729,7 @@ typeWithA tpa = loop
|
|||
Just t' -> return t'
|
||||
Nothing -> Left (TypeError ctx e (MissingField x t))
|
||||
_ -> do
|
||||
let text = docToLazyText (Dhall.Pretty.Internal.prettyLabel x)
|
||||
let text = Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabel x)
|
||||
Left (TypeError ctx e (NotARecord text r t))
|
||||
loop ctx e@(Project r xs ) = do
|
||||
t <- fmap Dhall.Core.normalize (loop ctx r)
|
||||
|
|
@ -754,7 +744,7 @@ typeWithA tpa = loop
|
|||
let adapt = Record . Data.HashMap.Strict.InsOrd.fromList
|
||||
fmap adapt (traverse process (Data.Set.toList xs))
|
||||
_ -> do
|
||||
let text = docToLazyText (Dhall.Pretty.Internal.prettyLabels xs)
|
||||
let text = Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabels xs)
|
||||
Left (TypeError ctx e (NotARecord text r t))
|
||||
loop ctx (Note s e' ) = case loop ctx e' of
|
||||
Left (TypeError ctx' (Note s' e'') m) -> Left (TypeError ctx' (Note s' e'') m)
|
||||
|
|
@ -778,9 +768,6 @@ instance Show X where
|
|||
instance Eq X where
|
||||
_ == _ = True
|
||||
|
||||
instance Buildable X where
|
||||
build = absurd
|
||||
|
||||
instance Data X where
|
||||
dataTypeOf = absurd
|
||||
gunfold _ _ _ = undefined
|
||||
|
|
@ -843,63 +830,37 @@ data TypeMessage s a
|
|||
| NoDependentTypes (Expr s a) (Expr s a)
|
||||
deriving (Show)
|
||||
|
||||
shortTypeMessage :: (Buildable a, Eq a, Pretty a) => TypeMessage s a -> Builder
|
||||
shortTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann
|
||||
shortTypeMessage msg =
|
||||
"\ESC[1;31mError\ESC[0m: " <> build short <> "\n"
|
||||
"\ESC[1;31mError\ESC[0m: " <> short <> "\n"
|
||||
where
|
||||
ErrorMessages {..} = prettyTypeMessage msg
|
||||
|
||||
longTypeMessage :: (Buildable a, Eq a, Pretty a) => TypeMessage s a -> Builder
|
||||
longTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann
|
||||
longTypeMessage msg =
|
||||
"\ESC[1;31mError\ESC[0m: " <> build short <> "\n"
|
||||
"\ESC[1;31mError\ESC[0m: " <> short <> "\n"
|
||||
<> "\n"
|
||||
<> long
|
||||
where
|
||||
ErrorMessages {..} = prettyTypeMessage msg
|
||||
|
||||
data ErrorMessages = ErrorMessages
|
||||
{ short :: Builder
|
||||
{ short :: Doc Ann
|
||||
-- ^ Default succinct 1-line explanation of what went wrong
|
||||
, long :: Builder
|
||||
, long :: Doc Ann
|
||||
-- ^ Longer and more detailed explanation of the error
|
||||
}
|
||||
|
||||
_NOT :: Builder
|
||||
_NOT :: Doc ann
|
||||
_NOT = "\ESC[1mnot\ESC[0m"
|
||||
|
||||
insert :: Pretty a => a -> Builder
|
||||
insert expression = builder
|
||||
where
|
||||
doc = "↳ " <> Pretty.align (Pretty.pretty expression)
|
||||
insert :: Pretty a => a -> Doc Ann
|
||||
insert expression = "↳ " <> Pretty.align (Pretty.pretty expression)
|
||||
|
||||
coloredDoc = fmap Dhall.Pretty.annToAnsiStyle doc
|
||||
prettyDiff :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Doc Ann
|
||||
prettyDiff exprL exprR = Dhall.Diff.diffNormalized exprL exprR
|
||||
|
||||
opts =
|
||||
Pretty.LayoutOptions
|
||||
{ Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 }
|
||||
|
||||
stream = Pretty.layoutPretty opts coloredDoc
|
||||
|
||||
lazyText = Pretty.renderLazy stream
|
||||
|
||||
builder = Builder.fromLazyText lazyText
|
||||
|
||||
prettyDiff :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Builder
|
||||
prettyDiff exprL exprR = builder
|
||||
where
|
||||
doc =
|
||||
fmap Dhall.Pretty.annToAnsiStyle (Dhall.Diff.diffNormalized exprL exprR)
|
||||
|
||||
opts = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
|
||||
|
||||
stream = Pretty.layoutPretty opts doc
|
||||
|
||||
lazyText = Pretty.renderLazy stream
|
||||
|
||||
builder = Builder.fromLazyText lazyText
|
||||
|
||||
prettyTypeMessage
|
||||
:: (Buildable a, Eq a, Pretty a) => TypeMessage s a -> ErrorMessages
|
||||
prettyTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> ErrorMessages
|
||||
prettyTypeMessage (UnboundVariable _) = ErrorMessages {..}
|
||||
-- We do not need to print variable name here. For the discussion see:
|
||||
-- https://github.com/dhall-lang/dhall-haskell/pull/116
|
||||
|
|
@ -1893,7 +1854,7 @@ prettyTypeMessage (MismatchedListElements i expr0 _expr1 expr2) =
|
|||
\" <> txt3 <> "\n"
|
||||
where
|
||||
txt0 = insert expr0
|
||||
txt1 = build i
|
||||
txt1 = pretty i
|
||||
txt3 = insert expr2
|
||||
|
||||
prettyTypeMessage (InvalidListElement i expr0 _expr1 expr2) =
|
||||
|
|
@ -1932,7 +1893,7 @@ prettyTypeMessage (InvalidListElement i expr0 _expr1 expr2) =
|
|||
\" <> txt3 <> "\n"
|
||||
where
|
||||
txt0 = insert expr0
|
||||
txt1 = build i
|
||||
txt1 = pretty i
|
||||
txt3 = insert expr2
|
||||
|
||||
prettyTypeMessage (InvalidOptionalType expr0) = ErrorMessages {..}
|
||||
|
|
@ -2475,7 +2436,7 @@ prettyTypeMessage (MustCombineARecord c expr0 expr1) = ErrorMessages {..}
|
|||
\ \n\
|
||||
\" <> txt1 <> "\n"
|
||||
where
|
||||
op = build c
|
||||
op = pretty c
|
||||
txt0 = insert expr0
|
||||
txt1 = insert expr1
|
||||
|
||||
|
|
@ -3029,9 +2990,9 @@ prettyTypeMessage (HandlerOutputTypeMismatch key0 expr0 key1 expr1) =
|
|||
\ \n\
|
||||
\" <> txt3 <> "\n"
|
||||
where
|
||||
txt0 = build key0
|
||||
txt0 = pretty key0
|
||||
txt1 = insert expr0
|
||||
txt2 = build key1
|
||||
txt2 = pretty key1
|
||||
txt3 = insert expr1
|
||||
|
||||
prettyTypeMessage (HandlerNotAFunction k expr0) = ErrorMessages {..}
|
||||
|
|
@ -3448,7 +3409,7 @@ buildBooleanOperator operator expr0 expr1 = ErrorMessages {..}
|
|||
txt0 = insert expr0
|
||||
txt1 = insert expr1
|
||||
|
||||
txt2 = build operator
|
||||
txt2 = pretty operator
|
||||
|
||||
buildNaturalOperator :: Pretty a => Text -> Expr s a -> Expr s a -> ErrorMessages
|
||||
buildNaturalOperator operator expr0 expr1 = ErrorMessages {..}
|
||||
|
|
@ -3509,41 +3470,46 @@ buildNaturalOperator operator expr0 expr1 = ErrorMessages {..}
|
|||
txt0 = insert expr0
|
||||
txt1 = insert expr1
|
||||
|
||||
txt2 = build operator
|
||||
txt2 = pretty operator
|
||||
|
||||
-- | A structured type error that includes context
|
||||
data TypeError s a = TypeError
|
||||
{ context :: Context (Expr s a)
|
||||
, current :: Expr s a
|
||||
, typeMessage :: TypeMessage s a
|
||||
} deriving (Typeable)
|
||||
}
|
||||
|
||||
instance (Buildable a, Buildable s, Eq a, Pretty a) => Show (TypeError s a) where
|
||||
show = Data.Text.Lazy.unpack . Builder.toLazyText . build
|
||||
|
||||
instance (Buildable a, Buildable s, Eq a, Pretty a, Typeable a, Typeable s) => Exception (TypeError s a)
|
||||
|
||||
instance (Buildable a, Buildable s, Eq a, Pretty a) => Buildable (TypeError s a) where
|
||||
build (TypeError ctx expr msg)
|
||||
= "\n"
|
||||
<> ( if Data.Text.Lazy.null (Builder.toLazyText (buildContext ctx))
|
||||
then ""
|
||||
else buildContext ctx <> "\n"
|
||||
)
|
||||
<> shortTypeMessage msg <> "\n"
|
||||
<> source
|
||||
instance (Eq a, Pretty s, Pretty a) => Show (TypeError s a) where
|
||||
show = Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty
|
||||
where
|
||||
buildKV (key, val) = build key <> " : " <> build val
|
||||
options =
|
||||
Pretty.LayoutOptions
|
||||
{ Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 }
|
||||
|
||||
buildContext =
|
||||
build
|
||||
. Data.Text.Lazy.unlines
|
||||
. map (Builder.toLazyText . buildKV)
|
||||
instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (TypeError s a)
|
||||
|
||||
instance (Eq a, Pretty s, Pretty a) => Pretty (TypeError s a) where
|
||||
pretty (TypeError ctx expr msg)
|
||||
= Pretty.unAnnotate
|
||||
("\n"
|
||||
<> ( if null (Dhall.Context.toList ctx)
|
||||
then ""
|
||||
else prettyContext ctx <> "\n"
|
||||
)
|
||||
<> shortTypeMessage msg <> "\n"
|
||||
<> source
|
||||
)
|
||||
where
|
||||
prettyKV (key, val) = pretty key <> " : " <> pretty val
|
||||
|
||||
prettyContext =
|
||||
Pretty.vsep
|
||||
. map prettyKV
|
||||
. reverse
|
||||
. Dhall.Context.toList
|
||||
|
||||
source = case expr of
|
||||
Note s _ -> build s
|
||||
Note s _ -> pretty s
|
||||
_ -> mempty
|
||||
|
||||
{-| Newtype used to wrap error messages so that they render with a more
|
||||
|
|
@ -3552,34 +3518,39 @@ instance (Buildable a, Buildable s, Eq a, Pretty a) => Buildable (TypeError s a)
|
|||
newtype DetailedTypeError s a = DetailedTypeError (TypeError s a)
|
||||
deriving (Typeable)
|
||||
|
||||
instance (Buildable a, Buildable s, Eq a, Pretty a) => Show (DetailedTypeError s a) where
|
||||
show = Data.Text.Lazy.unpack . Builder.toLazyText . build
|
||||
|
||||
instance (Buildable a, Buildable s, Eq a, Pretty a, Typeable a, Typeable s) => Exception (DetailedTypeError s a)
|
||||
|
||||
instance (Buildable a, Buildable s, Eq a, Pretty a) => Buildable (DetailedTypeError s a) where
|
||||
build (DetailedTypeError (TypeError ctx expr msg))
|
||||
= "\n"
|
||||
<> ( if Data.Text.Lazy.null (Builder.toLazyText (buildContext ctx))
|
||||
then ""
|
||||
else buildContext ctx <> "\n"
|
||||
)
|
||||
<> longTypeMessage msg <> "\n"
|
||||
<> "────────────────────────────────────────────────────────────────────────────────\n"
|
||||
<> "\n"
|
||||
<> source
|
||||
instance (Eq a, Pretty s, Pretty a) => Show (DetailedTypeError s a) where
|
||||
show = Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty
|
||||
where
|
||||
buildKV (key, val) = build key <> " : " <> build val
|
||||
options =
|
||||
Pretty.LayoutOptions
|
||||
{ Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 }
|
||||
|
||||
buildContext =
|
||||
build
|
||||
. Data.Text.Lazy.unlines
|
||||
. map (Builder.toLazyText . buildKV)
|
||||
instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (DetailedTypeError s a)
|
||||
|
||||
instance (Eq a, Pretty s, Pretty a) => Pretty (DetailedTypeError s a) where
|
||||
pretty (DetailedTypeError (TypeError ctx expr msg))
|
||||
= Pretty.unAnnotate
|
||||
( "\n"
|
||||
<> ( if null (Dhall.Context.toList ctx)
|
||||
then ""
|
||||
else prettyContext ctx <> "\n"
|
||||
)
|
||||
<> longTypeMessage msg <> "\n"
|
||||
<> "────────────────────────────────────────────────────────────────────────────────\n"
|
||||
<> "\n"
|
||||
<> source
|
||||
)
|
||||
where
|
||||
prettyKV (key, val) = pretty key <> " : " <> pretty val
|
||||
|
||||
prettyContext =
|
||||
Pretty.vsep
|
||||
. map prettyKV
|
||||
. reverse
|
||||
. Dhall.Context.toList
|
||||
|
||||
source = case expr of
|
||||
Note s _ -> build s
|
||||
Note s _ -> pretty s
|
||||
_ -> mempty
|
||||
|
||||
{-| This function verifies that a custom context is well-formed so that
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user