summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/EnsureProperty.hs13
-rw-r--r--src/Propellor/Types.hs13
-rw-r--r--src/Propellor/Types/MetaTypes.hs54
3 files changed, 60 insertions, 20 deletions
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 "<unknown>"
+
+type family UnknownTypeNote :: Maybe ErrorMessage where
+ UnknownTypeNote = 'Just ('Text "(Property <unknown> 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