ehmry/dhall-haskell
ehmry
/
dhall-haskell
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Output the context of a type error with syntax highlighting (#1556)

This commit is contained in:
Simon Jakobi 2019-11-19 08:11:22 +01:00 committed by mergify[bot]
parent e12dd9adce
commit 3fdf075259
2 changed files with 43 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
dhall/src/Dhall/TypeCheck.hs
View File

@ -4252,21 +4252,23 @@ data TypeError s a = TypeError
}
instance (Eq a, Pretty s, Pretty a) => Show (TypeError s a) where
show = Pretty.renderString . Dhall.Pretty.layout . Pretty.pretty
show = Pretty.renderString . Dhall.Pretty.layout . prettyTypeError
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 _ expr msg)
= Pretty.unAnnotate
( "\n"
<> shortTypeMessage msg <> "\n"
<> source
)
where
source = case expr of
Note s _ -> pretty s
_ -> mempty
pretty = Pretty.unAnnotate . prettyTypeError
prettyTypeError :: (Eq a, Pretty s, Pretty a) => TypeError s a -> Doc Ann
prettyTypeError (TypeError _ expr msg) =
( "\n"
<> shortTypeMessage msg <> "\n"
<> source
)
where
source = case expr of
Note s _ -> pretty s
_ -> mempty
{-| Wrap a type error in this exception type to censor source code and
`Text` literals from the error message
@ -4425,36 +4427,39 @@ newtype DetailedTypeError s a = DetailedTypeError (TypeError s a)
deriving (Typeable)
instance (Eq a, Pretty s, Pretty a) => Show (DetailedTypeError s a) where
show = Pretty.renderString . Dhall.Pretty.layout . Pretty.pretty
show = Pretty.renderString . Dhall.Pretty.layout . prettyDetailedTypeError
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\n"
)
<> longTypeMessage msg <> "\n"
<> "────────────────────────────────────────────────────────────────────────────────\n"
<> "\n"
<> source
)
where
prettyKV (key, val) =
pretty key <> " : " <> Dhall.Util.snipDoc (pretty val)
pretty = Pretty.unAnnotate . prettyDetailedTypeError
prettyContext =
Pretty.vsep
. map prettyKV
. reverse
. Dhall.Context.toList
prettyDetailedTypeError :: (Eq a, Pretty s, Pretty a) => DetailedTypeError s a -> Doc Ann
prettyDetailedTypeError (DetailedTypeError (TypeError ctx expr msg)) =
( "\n"
<> ( if null (Dhall.Context.toList ctx)
then ""
else prettyContext ctx <> "\n\n"
)
<> longTypeMessage msg <> "\n"
<> "────────────────────────────────────────────────────────────────────────────────\n"
<> "\n"
<> source
)
where
prettyKV (key, val) =
Dhall.Util.snipDoc
(Dhall.Pretty.Internal.prettyLabel key <> " : " <> Dhall.Pretty.prettyExpr val)
source = case expr of
Note s _ -> pretty s
_ -> mempty
prettyContext =
Pretty.vsep
. map prettyKV
. reverse
. Dhall.Context.toList
source = case expr of
Note s _ -> pretty s
_ -> mempty
{-| This function verifies that a custom context is well-formed so that
type-checking will not loop

6
dhall/src/Dhall/Util.hs
View File

@ -31,8 +31,8 @@ import Dhall.Src (Src)
import qualified Control.Exception
import qualified Data.Text
import qualified Data.Text.IO
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal
import qualified Dhall.Parser
import qualified Dhall.Pretty
@ -81,7 +81,7 @@ snipDoc doc = Pretty.align (Pretty.pretty (snip text))
ansiStream = fmap Dhall.Pretty.annToAnsiStyle stream
text = Pretty.renderStrict ansiStream
text = Pretty.Terminal.renderStrict ansiStream
takeEnd :: Int -> [a] -> [a]
takeEnd n l = go (drop n l) l