diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,9 +1,16 @@ -propellor (5.14.1) unstable; urgency=medium +propellor (5.15) unstable; urgency=medium - * Fix config.hs example, which was accidentially joeyconfig.hs in the - previous release. + * Improve propellor's MetaTypes implementation to avoid an expontential + blowup when several MetaTypes fail to unify. This should result in less + memory use by ghc when there's a type error. + * Avoid OOM when built by ghc 9.2. + * Thanks to the ghc developers for their assistance, particularly spj + and Sam Derbyshire. + * Remove workaround to ghc using a lot of memory displaying an error + message about a property of a host having the wrong number of + arguments. This brings back clear error messages in such situations. - -- Joey Hess Sat, 15 Oct 2022 14:44:01 -0400 + -- Joey Hess Tue, 15 Nov 2022 15:34:11 -0400 propellor (5.14) unstable; urgency=medium diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,9 +1,16 @@ -propellor (5.14.1) unstable; urgency=medium +propellor (5.15) unstable; urgency=medium - * Fix config.hs example, which was accidentially joeyconfig.hs in the - previous release. + * Improve propellor's MetaTypes implementation to avoid an expontential + blowup when several MetaTypes fail to unify. This should result in less + memory use by ghc when there's a type error. + * Avoid OOM when built by ghc 9.2. + * Thanks to the ghc developers for their assistance, particularly spj + and Sam Derbyshire. + * Remove workaround to ghc using a lot of memory displaying an error + message about a property of a host having the wrong number of + arguments. This brings back clear error messages in such situations. - -- Joey Hess Sat, 15 Oct 2022 14:44:01 -0400 + -- Joey Hess Tue, 15 Nov 2022 15:34:11 -0400 propellor (5.14) unstable; urgency=medium diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 5.14.1 +Version: 5.15 Cabal-Version: 1.20 License: BSD2 Maintainer: Joey Hess @@ -36,7 +36,7 @@ It is configured using haskell. Flag WithTypeErrors - Description: Build with type-errors library for better error messages and less memory use + Description: Build with type-errors library for better error messages Library Default-Language: Haskell2010 diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs --- a/src/Propellor/Property/Apt/PPA.hs +++ b/src/Propellor/Property/Apt/PPA.hs @@ -31,12 +31,11 @@ instance IsString PPA where -- | Parse strings like "ppa:zfs-native/stable" into a PPA. - fromString s = - let - [_, ppa] = split "ppa:" s - [acct, arch] = split "/" ppa - in - PPA acct arch + fromString s = case split "ppa:" s of + [_, ppa] -> case split "/" ppa of + [acct, arch] -> PPA acct arch + _ -> PPA s s + _ -> PPA s s -- | Adds a PPA to the local system repositories. addPpa :: PPA -> Property DebianLike @@ -89,11 +88,9 @@ val asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc] instance IsString AptSource where - fromString s = - let - url:suite:comps = drop 1 . words $ s - in - AptSource url suite comps + fromString s = case drop 1 (words s) of + url:suite:comps -> AptSource url suite comps + _ -> AptSource s s [] -- | A repository for apt-add-source, either a PPA or a regular repository line. data AptRepository = AptRepositoryPPA PPA | AptRepositorySource AptSource diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs --- a/src/Propellor/Property/ZFS/Process.hs +++ b/src/Propellor/Property/ZFS/Process.hs @@ -12,8 +12,11 @@ -- | Gets the properties of a ZFS volume. zfsGetProperties :: ZFS -> IO ZFSProperties zfsGetProperties z = - let plist = fromPropertyList . map (\(_:k:v:_) -> (k, v)) . (map (split "\t")) + let plist = fromPropertyList . mapMaybe parse . (map (split "\t")) in plist <$> runZfs "get" [Just "-H", Just "-p", Just "all"] z + where + parse (_:k:v:_) = Just (k, v) + parse _ = Nothing zfsExists :: ZFS -> IO Bool zfsExists z = any id . map (isInfixOf (zfsName z)) diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -41,6 +41,7 @@ import GHC.TypeLits hiding (type (+)) import GHC.Exts (Constraint) import Data.Type.Bool +import Data.Kind (Type) #ifdef WITH_TYPE_ERRORS import Type.Errors @@ -118,7 +119,7 @@ -- Which is shorthand for this type: -- -- > MetaTypes '[WithInfo, Targeting OSDebian] -type family a + b :: * where +type family a + b :: Type where (MetaTypes a) + (MetaTypes b) = MetaTypes (Concat a b) type family Concat (list1 :: [a]) (list2 :: [a]) :: [a] where @@ -128,11 +129,22 @@ -- | Combine two MetaTypes lists, yielding a list -- that has targets present in both, and nontargets present in either. type family Combine (list1 :: [a]) (list2 :: [a]) :: [a] where - Combine (list1 :: [a]) (list2 :: [a]) = - (Concat - (NonTargets list1 `Union` NonTargets list2) - (Targets list1 `Intersect` Targets list2) - ) + Combine ('WithInfo : list1) ('WithInfo : list2) = 'WithInfo ': + list1 `Intersect` list2 + Combine ('WithInfo : list1) list2 = 'WithInfo ': + list1 `Intersect` list2 + Combine list1 ('WithInfo : list2) = 'WithInfo ': + list1 `Intersect` list2 + Combine list1 list2 = + list1 `Intersect` list2 + -- This is a cleaner implementation, but it causes an exponential + -- blowup of the type checker due to referencing list1 twice on + -- the right hand side. + -- Combine (list1 :: [a]) (list2 :: [a]) = + -- (Concat + -- (NonTargets list1 `Union` NonTargets list2) + -- (Targets list1 `Intersect` Targets list2) + -- ) -- | Checks if two MetaTypes lists can be safly combined; -- eg they have at least one Target in common. @@ -172,7 +184,7 @@ type family CannotCombine (list1 :: [a]) (list2 :: [a]) (note :: Maybe ErrorMessage) :: Constraint where -- Checking IfStuck is to avoid ugly error -- message leaking type families from this module. - CannotCombine list1 list2 'Nothing = + CannotCombine list1 list2 note = IfStuck list1 (IfStuck list2 (DelayError (CannotCombineMessage UnknownType UnknownType UnknownTypeNote)) @@ -180,21 +192,8 @@ ) (IfStuck list2 (DelayError (CannotCombineMessage (PrettyPrintMetaTypes list1) UnknownType UnknownTypeNote)) - (DelayErrorFcf (CannotCombineMessage (PrettyPrintMetaTypes list1) (PrettyPrintMetaTypes list2) 'Nothing)) + (DelayErrorFcf (CannotCombineMessage (PrettyPrintMetaTypes list1) (PrettyPrintMetaTypes list2) note)) ) - -- When there's a note, don't display the MetaTypes at all. - -- This is because the note is used when eg, combining properties - -- in a host with (&), and in that case, it's likely that the - -- problem resulted in the type checker getting stuck, and that - -- displaying the MetaTypes would involve a massive error messsage. - -- Displaying, or even checking IfStuck in that case can result in - -- huge amounts of memory being used by ghc. So, avoid it, and let - -- the note point the user in the right direction to fixing their - -- mistake. - CannotCombine list1 list2 ('Just note) = - TypeError ('Text "Cannot combine two Properties." - ':$$: 'Text "(They may have conflicting MetaTypes, or the wrong number of arguments.)" - ':$$: note) type family UnknownType :: ErrorMessage where UnknownType = 'Text "" diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs --- a/src/Propellor/Types/Singletons.hs +++ b/src/Propellor/Types/Singletons.hs @@ -1,17 +1,14 @@ {-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, FlexibleContexts #-} --- | Simple implementation of singletons, portable back to ghc 7.6.3 +-- | Simple implementation of singletons, portable back to ghc 8.0.1 module Propellor.Types.Singletons ( module Propellor.Types.Singletons, KProxy(..) ) where -#if __GLASGOW_HASKELL__ > 707 +import Data.Kind (Type) import Data.Proxy (KProxy(..)) -#else -data KProxy (a :: *) = KProxy -#endif -- | The data family of singleton types. data family Sing (x :: k) @@ -34,7 +31,7 @@ instance SingI 'False where sing = FalseS class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where - type DemoteRep kparam :: * + type DemoteRep kparam :: Type -- | From singleton to value. fromSing :: Sing (a :: k) -> DemoteRep kparam