From 011530bba1bae05204a9025205f485d08f6d199d Mon Sep 17 00:00:00 2001 From: Dmitrii Kovanikov Date: Sat, 20 Jul 2019 20:48:42 +0800 Subject: [PATCH] [#180] Use type-errors-pretty package (#182) Resolves #180 --- package.yaml | 1 + polysemy.cabal | 5 +- src/Polysemy/Internal/CustomErrors.hs | 81 +++++++++------------------ stack.yaml | 2 +- 4 files changed, 31 insertions(+), 58 deletions(-) diff --git a/package.yaml b/package.yaml index 611d3a1..1417821 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,7 @@ dependencies: - unagi-chan >= 0.4.0.0 && < 0.5 - async >= 2.2 && < 3 - type-errors >= 0.2.0.0 +- type-errors-pretty >= 0.0.0.0 && < 0.1 default-extensions: - DataKinds diff --git a/polysemy.cabal b/polysemy.cabal index 4bea9b5..5e39f13 100644 --- a/polysemy.cabal +++ b/polysemy.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7e0e9242c36e377756ae6ef007d19a16cdaf3f244855b0bfc97e267f4df143ea +-- hash: 168b7f25b456d0a92b6c245a91e1acc9c81ef40eaa2893f2eb6a238abd74f7f9 name: polysemy version: 0.7.0.0 @@ -83,6 +83,7 @@ library , th-abstraction >=0.3.1.0 && <0.4 , transformers >=0.5.2.0 && <0.6 , type-errors >=0.2.0.0 + , type-errors-pretty >=0.0.0.0 && <0.1 , unagi-chan >=0.4.0.0 && <0.5 if impl(ghc < 8.6) default-extensions: MonadFailDesugaring TypeInType @@ -142,6 +143,7 @@ test-suite polysemy-test , th-abstraction >=0.3.1.0 && <0.4 , transformers >=0.5.2.0 && <0.6 , type-errors >=0.2.0.0 + , type-errors-pretty >=0.0.0.0 && <0.1 , unagi-chan >=0.4.0.0 && <0.5 if impl(ghc < 8.6) default-extensions: MonadFailDesugaring TypeInType @@ -174,6 +176,7 @@ benchmark polysemy-bench , th-abstraction >=0.3.1.0 && <0.4 , transformers >=0.5.2.0 && <0.6 , type-errors >=0.2.0.0 + , type-errors-pretty >=0.0.0.0 && <0.1 , unagi-chan >=0.4.0.0 && <0.5 if impl(ghc < 8.6) default-extensions: MonadFailDesugaring TypeInType diff --git a/src/Polysemy/Internal/CustomErrors.hs b/src/Polysemy/Internal/CustomErrors.hs index 7c3f250..facda16 100644 --- a/src/Polysemy/Internal/CustomErrors.hs +++ b/src/Polysemy/Internal/CustomErrors.hs @@ -17,10 +17,11 @@ module Polysemy.Internal.CustomErrors import Data.Kind import Fcf -import GHC.TypeLits +import GHC.TypeLits (Symbol) import Polysemy.Internal.Kind import Polysemy.Internal.CustomErrors.Redefined import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck) +import Type.Errors.Pretty (type (<>), type (%)) ------------------------------------------------------------------------------ @@ -37,9 +38,7 @@ type family DefiningModuleForEffect (e :: k) :: Symbol where -- TODO(sandy): Put in type-errors -type ShowTypeBracketed t = 'Text "(" - ':<>: 'ShowType t - ':<>: 'Text ")" +type ShowTypeBracketed t = "(" <> t <> ")" ------------------------------------------------------------------------------ @@ -67,24 +66,15 @@ type AmbigousEffectMessage (rstate :: EffectRowCtor) (r :: EffectRow) (e :: k) (t :: Effect) - (vs :: [Type]) = - ( 'Text "Ambiguous use of effect '" - ':<>: 'ShowType e - ':<>: 'Text "'" - ':$$: 'Text "Possible fix:" - ':$$: 'Text " add (Member (" - ':<>: 'ShowType t - ':<>: 'Text ") " - ':<>: ShowRQuoted rstate r - ':<>: 'Text ") to the context of " - ':$$: 'Text " the type signature" - ':$$: 'Text "If you already have the constraint you want, instead" - ':$$: 'Text " add a type application to specify" - ':$$: 'Text " " - ':<>: PrettyPrintList vs - ':<>: 'Text " directly, or activate polysemy-plugin which" - ':$$: 'Text " can usually infer the type correctly." - ) + (vs :: [Type]) + = "Ambiguous use of effect '" <> e <> "'" + % "Possible fix:" + % " add (Member (" <> t <> ") " <> ShowRQuoted rstate r <> ") to the context of " + % " the type signature" + % "If you already have the constraint you want, instead" + % " add a type application to specify" + % " " <> PrettyPrintList vs <> " directly, or activate polysemy-plugin which" + % " can usually infer the type correctly." type AmbiguousSend r e = (IfStuck r @@ -110,18 +100,10 @@ type family AmbiguousSendError rstate r e where AmbiguousSendError rstate r e = TypeError - ( 'Text "Could not deduce: (Member " - ':<>: 'ShowType e - ':<>: 'Text " " - ':<>: ShowRQuoted rstate r - ':<>: 'Text ") " - ':$$: 'Text "Fix:" - ':$$: 'Text " add (Member " - ':<>: 'ShowType e - ':<>: 'Text " " - ':<>: 'ShowType r - ':<>: 'Text ") to the context of" - ':$$: 'Text " the type signature" + ( "Could not deduce: (Member " <> e <> " " <> ShowRQuoted rstate r <> ") " + % "Fix:" + % " add (Member " <> e <> " " <> r <> ") to the context of" + % " the type signature" ) @@ -129,16 +111,10 @@ data FirstOrderErrorFcf :: k -> Symbol -> Exp Constraint type instance Eval (FirstOrderErrorFcf e fn) = $(te[t| UnlessPhantom (e PHANTOM) - ( 'Text "'" - ':<>: 'ShowType e - ':<>: 'Text "' is higher-order, but '" - ':<>: 'Text fn - ':<>: 'Text "' can help only" - ':$$: 'Text "with first-order effects." - ':$$: 'Text "Fix:" - ':$$: 'Text " use '" - ':<>: 'Text fn - ':<>: 'Text "H' instead." + ( "'" <> e <> "' is higher-order, but '" <> fn <> "' can help only" + % "with first-order effects." + % "Fix:" + % " use '" <> fn <> "H' instead." ) |]) ------------------------------------------------------------------------------ @@ -150,19 +126,13 @@ type FirstOrder (e :: Effect) fn = UnlessStuck e (FirstOrderErrorFcf e fn) ------------------------------------------------------------------------------ -- | Unhandled effects type UnhandledEffectMsg e - = 'Text "Unhandled effect '" - ':<>: 'ShowType e - ':<>: 'Text "'" - ':$$: 'Text "Probable fix:" - ':$$: 'Text " add an interpretation for '" - ':<>: 'ShowType e - ':<>: 'Text "'" + = "Unhandled effect '" <> e <> "'" + % "Probable fix:" + % " add an interpretation for '" <> e <> "'" type CheckDocumentation e - = 'Text " If you are looking for inspiration, try consulting" - ':$$: 'Text " the documentation for module '" - ':<>: 'Text (DefiningModuleForEffect e) - ':<>: 'Text "'" + = " If you are looking for inspiration, try consulting" + % " the documentation for module '" <> DefiningModuleForEffect e <> "'" type family UnhandledEffect e where UnhandledEffect e = @@ -173,4 +143,3 @@ type family UnhandledEffect e where data DoError :: ErrorMessage -> Exp k type instance Eval (DoError a) = TypeError a - diff --git a/stack.yaml b/stack.yaml index d503e9e..35c3f89 100644 --- a/stack.yaml +++ b/stack.yaml @@ -16,4 +16,4 @@ extra-deps: - th-abstraction-0.3.1.0 - unagi-chan-0.4.1.0 - type-errors-0.2.0.0 - +- type-errors-pretty-0.0.0.0