From de21ef26861db458b0dfb0212cf501f9f8ed459b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 1 Jul 2019 18:27:48 -0400 Subject: optionally use type-errors to detect stuckness Use the type-errors library to detect when the type checker gets stuck unable to reduce type-level operations on MetaTypes, and avoid displaying massive error messages in such a case. But, since type-errors is a new library not available in eg Debian yet, added a WithTypeErrors build flag. When the library is not available, cabal will automatically disable that build flag, and it will build without the type-errors library. This is most often used when combining properties of different types. If the MetaTypes don't have an OS in common, the error message used to be "Property " followed by pages of MetaTypes operations. Now it looks like this: • Cannot combine Properties: Property Property HasInfo + Debian + Buntish + ArchLinux + FreeBSD (Property is often due to a partially applied Property constructor, or due to passing the wrong type to a Property constructor.) Also it's used in ensureProperty to detect a case where the outer MetaTypes need to be inferred in order to check if the inner MetaTypes match, but the type checker is unable to infer it: • ensureProperty outer Property type is not able to be inferred here. Consider adding a type annotation. • When checking the inferred type writeConfig :: forall (outer :: [Propellor.Types.MetaTypes.MetaType]) t. And it's used in tightenTargets to detect when ghc is unable to infer the desired type of Property: • Unable to infer desired Property type in this use of tightenTargets. Consider adding a type annotation. • When checking the inferred type mk :: forall (tightened :: [Propellor.Types.MetaTypes.MetaType]). --- debian/changelog | 9 ++++++- propellor.cabal | 6 +++++ src/Propellor/EnsureProperty.hs | 13 +++++++--- src/Propellor/Types.hs | 13 +++++++--- src/Propellor/Types/MetaTypes.hs | 54 +++++++++++++++++++++++++++++----------- stack.yaml | 3 +++ 6 files changed, 77 insertions(+), 21 deletions(-) diff --git a/debian/changelog b/debian/changelog index 8944ff8f..c21c29f1 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,8 +3,15 @@ propellor (5.9.0) UNRELEASED; urgency=medium * Avoid displaying an excessive amount of type error messages when many properties have been combined in a props list. * Added custom type error messages when Properties don't combine due to - conflicting metatypes. + conflicting MetaTypes. * Added custom type error messages for ensureProperty and tightenTargets. + * Use the type-errors library to detect when the type checker gets stuck + unable to reduce type-level operations on MetaTypes, and avoid + displaying massive error messages in such a case. + * But, since type-errors is a new library not available in eg Debian + yet, added a WithTypeErrors build flag. When the library is not + available, cabal will automatically disable that build flag, + and it will build without the type-errors library. * ensureProperty: The constraints have been simplified to EnsurePropertyAllowed. (API change) * ensureProperty: The contraints have been simplified diff --git a/propellor.cabal b/propellor.cabal index 300313c0..71d3c578 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -35,6 +35,9 @@ Description: . It is configured using haskell. +Flag WithTypeErrors + Description: Build with type-errors library for better error messages + Library Default-Language: Haskell98 GHC-Options: -Wall -fno-warn-tabs -O0 @@ -47,6 +50,9 @@ Library directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable + if flag(WithTypeErrors) + Build-Depends: type-errors + CPP-Options: -DWITH_TYPE_ERRORS Exposed-Modules: Propellor diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index 01203d04..5ed0325f 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -65,9 +65,16 @@ type family EnsurePropertyTargetOSMatches inner outer where EnsurePropertyTargetOSMatches inner outer = If (Targets outer `IsSubset` Targets inner) 'True - ( TypeError - ( 'Text "ensureProperty inner Property is missing support for: " - ':$$: PrettyPrintMetaTypes (Difference (Targets outer) (Targets inner)) + (IfStuck (Targets outer) + (TypeError + ('Text "ensureProperty outer Property type is not able to be inferred here." + ':$$: 'Text "Consider adding a type annotation." + ) + ) + (TypeError + ('Text "ensureProperty inner Property is missing support for: " + ':$$: PrettyPrintMetaTypes (Difference (Targets outer) (Targets inner)) + ) ) ) diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index e8e92332..026babf0 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -224,9 +224,16 @@ type family TightenTargetsAllowed untightened tightened where If (Targets tightened `IsSubset` Targets untightened && NonTargets untightened `IsSubset` NonTargets tightened) 'True - ( TypeError - ( 'Text "This use of tightenTargets would widen, not narrow, adding: " - ':$$: PrettyPrintMetaTypes (Difference (Targets tightened) (Targets untightened)) + (IfStuck (Targets tightened) + (TypeError + ('Text "Unable to infer desired Property type in this use of tightenTargets." + ':$$: ('Text "Consider adding a type annotation.") + ) + ) + (TypeError + ('Text "This use of tightenTargets would widen, not narrow, adding: " + ':$$: PrettyPrintMetaTypes (Difference (Targets tightened) (Targets untightened)) + ) ) ) diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs index beb9ff61..567f533a 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-} +{-# LANGUAGE CPP #-} module Propellor.Types.MetaTypes ( MetaType(..), @@ -28,6 +29,7 @@ module Propellor.Types.MetaTypes ( Union, Intersect, Difference, + IfStuck, ) where import Propellor.Types.Singletons @@ -36,6 +38,13 @@ import Propellor.Types.OS import GHC.TypeLits hiding (type (+)) import Data.Type.Bool +#ifdef WITH_TYPE_ERRORS +import Type.Errors +#else +type family IfStuck (expr :: k) (b :: k1) (c :: k1) :: k1 where + IfStuck expr b c = c +#endif + data MetaType = Targeting TargetOS -- ^ A target OS of a Property | WithInfo -- ^ Indicates that a Property has associated Info @@ -141,28 +150,45 @@ type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: Bool where CheckCombinable list1 list2 = If (IsCombinable list1 list2) 'True - ( TypeError (CannotCombine list1 list2) - ) + (CannotCombine list1 list2 'Nothing) -- | Allows providing an additional note. type family CheckCombinableNote (list1 :: [a]) (list2 :: [a]) (note :: ErrorMessage) :: Bool where CheckCombinableNote list1 list2 note = If (IsCombinable list1 list2) 'True - ( TypeError - ( CannotCombine list1 list2 - ':$$: 'Text "(" - ':<>: note - ':<>: 'Text ")" - ) + (CannotCombine list1 list2 + ('Just ('Text "(" ':<>: note ':<>: 'Text ")")) + ) + +-- Checking IfStuck is to avoid massive and useless error message leaking +-- type families from this module. +type family CannotCombine (list1 :: [a]) (list2 :: [a]) (note :: Maybe ErrorMessage) :: Bool where + CannotCombine list1 list2 note = + IfStuck list1 + (IfStuck list2 + (TypeError (CannotCombineMessage UnknownType UnknownType UnknownTypeNote)) + (TypeError (CannotCombineMessage UnknownType (PrettyPrintMetaTypes list2) UnknownTypeNote)) ) + (IfStuck list2 + (TypeError (CannotCombineMessage (PrettyPrintMetaTypes list1) UnknownType UnknownTypeNote)) + (TypeError (CannotCombineMessage (PrettyPrintMetaTypes list1) (PrettyPrintMetaTypes list2) note)) + ) + +type family UnknownType :: ErrorMessage where + UnknownType = 'Text "" + +type family UnknownTypeNote :: Maybe ErrorMessage where + UnknownTypeNote = 'Just ('Text "(Property is often due to a partially applied Property constructor, or due to passing the wrong type to a Property constructor.)") -type family CannotCombine (list1 :: [a]) (list2 :: [a]) :: ErrorMessage where - CannotCombine list1 list2 = - 'Text "Cannot combine properties with MetaTypes" - ':$$: ('Text " " ':<>: PrettyPrintMetaTypes list1) - ':$$: 'Text " vs" - ':$$: ('Text " " ':<>: PrettyPrintMetaTypes list2) +type family CannotCombineMessage (a :: ErrorMessage) (b :: ErrorMessage) (note :: Maybe ErrorMessage) :: ErrorMessage where + CannotCombineMessage a b ('Just note) = + CannotCombineMessage a b 'Nothing + ':$$: note + CannotCombineMessage a b 'Nothing = + 'Text "Cannot combine Properties:" + ':$$: ('Text " Property " ':<>: a) + ':$$: ('Text " Property " ':<>: b) type family IsTarget (a :: t) :: Bool where IsTarget ('Targeting a) = 'True diff --git a/stack.yaml b/stack.yaml index eb243950..84dbf12e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,6 @@ resolver: lts-9.21 packages: - '.' +extra-deps: +- type-errors-0.1.0.0 +- first-class-families-0.5.0.0 -- cgit v1.2.3