moving to using the GADT

The problem this exposes has to do with requires. As implemented,
requires yields either a Property HasInfo or a Property NoInfo depending
on its inputs. That works. But look what happens when it's used:

*Propellor.Types> let foo = IProperty "foo" (return NoChange) mempty mempty
*Propellor.Types> let bar = IProperty "bar" (return NoChange) mempty mempty
*Propellor.Types> foo `requires` bar

<interactive>:17:5:
    No instance for (Requires (Property HasInfo) (Property HasInfo) r0)
      arising from a use of `requires'
    The type variable `r0' is ambiguous
    Possible fix: add a type signature that fixes these type variable(s)
    Note: there is a potential instance available:
      instance Requires
                 (Property HasInfo) (Property HasInfo) (Property HasInfo)
        -- Defined at Propellor/Types.hs:167:10
    Possible fix:
      add an instance declaration for
      (Requires (Property HasInfo) (Property HasInfo) r0)
    In the expression: foo `requires` bar
    In an equation for `it': it = foo `requires` bar

This can be avoided by specifying the result type:

*Propellor.Types> (foo `requires` bar) :: Property HasInfo
property "foo"

But then when multiple `requires` are given, the result type has to be
given each time:

*Propellor.Types> (foo `requires` bar `requires` bar) :: Property HasInfo
<interactive>:22:6:
    No instance for (Requires (Property HasInfo) (Property HasInfo) x0)
      arising from a use of `requires'
    The type variable `x0' is ambiguous
    Possible fix: add a type signature that fixes these type variable(s)
    Note: there is a potential instance available:
      instance Requires
                 (Property HasInfo) (Property HasInfo) (Property HasInfo)
        -- Defined at Propellor/Types.hs:167:10
    Possible fix:
      add an instance declaration for
      (Requires (Property HasInfo) (Property HasInfo) x0)
    In the first argument of `requires', namely `foo `requires` bar'
    In the expression:
        (foo `requires` bar `requires` bar) :: Property HasInfo
    In an equation for `it':
        it = (foo `requires` bar `requires` bar) :: Property HasInfo

<interactive>:22:21:
    No instance for (Requires x0 (Property HasInfo) (Property HasInfo))
      arising from a use of `requires'
    The type variable `x0' is ambiguous
    Possible fix: add a type signature that fixes these type variable(s)
    Note: there are several potential instances:
      instance Requires
                 (Property NoInfo) (Property HasInfo) (Property HasInfo)
        -- Defined at Propellor/Types.hs:175:10
      instance Requires
                 (Property HasInfo) (Property HasInfo) (Property HasInfo)
        -- Defined at Propellor/Types.hs:167:10
    Possible fix:
      add an instance declaration for
      (Requires x0 (Property HasInfo) (Property HasInfo))
    In the expression:
        (foo `requires` bar `requires` bar) :: Property HasInfo
    In an equation for `it':
        it = (foo `requires` bar `requires` bar) :: Property HasInfo

*Propellor.Types> (((foo `requires` bar) :: Property HasInfo) `requires` bar) :: Property HasInfo
property "foo"

Yuggh!

src/Propellor/Engine.hs

@@ -45,7 +45,7 @@ mainProperties host = do
 		FailedChange -> exitWith (ExitFailure 1)
 		_ -> exitWith ExitSuccess
   where
-	ps = hostProperties host
+	ps = map ignoreInfo $ hostProperties host
 
 -- | Runs a Propellor action with the specified host.
 --
@@ -66,13 +66,12 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc
 -- | For when code running in the Propellor monad needs to ensure a
 -- Property.
 --
--- Note that the Info of the Property is not propigated out, so it will
+-- This can only be used on a Property that has NoInfo.
--- not be visible to propellor, unless you arrange for it to be propigated.
+ensureProperty :: Property NoInfo -> Propellor Result
-ensureProperty :: Property -> Propellor Result
 ensureProperty = catchPropellor . propertySatisfy
 
 -- | Ensures a list of Properties, with a display of each as it runs.
-ensureProperties :: [Property] -> Propellor Result
+ensureProperties :: [Property NoInfo] -> Propellor Result
 ensureProperties ps = ensure ps NoChange
   where
 	ensure [] rs = return rs

src/Propellor/Info.hs

@@ -12,13 +12,13 @@ import Data.Maybe
 import Data.Monoid
 import Control.Applicative
 
-pureInfoProperty :: Desc -> Info -> Property 
+pureInfoProperty :: Desc -> Info -> Property HasInfo
 pureInfoProperty desc i = mkProperty ("has " ++ desc) (return NoChange) i mempty
 
 askInfo :: (Info -> Val a) -> Propellor (Maybe a)
 askInfo f = asks (fromVal . f . hostInfo)
 
-os :: System -> Property
+os :: System -> Property HasInfo
 os system = pureInfoProperty ("Operating " ++ show system) $
 	mempty { _os = Val system }
 
@@ -34,11 +34,11 @@ getOS = askInfo _os
 -- When propellor --spin is used to deploy a host, it checks
 -- if the host's IP Property matches the DNS. If the DNS is missing or
 -- out of date, the host will instead be contacted directly by IP address.
-ipv4 :: String -> Property
+ipv4 :: String -> Property HasInfo
 ipv4 = addDNS . Address . IPv4
 
 -- | Indidate that a host has an AAAA record in the DNS.
-ipv6 :: String -> Property
+ipv6 :: String -> Property HasInfo
 ipv6 = addDNS . Address . IPv6
 
 -- | Indicates another name for the host in the DNS.
@@ -47,7 +47,7 @@ ipv6 = addDNS . Address . IPv6
 -- to use their address, rather than using a CNAME. This avoids various
 -- problems with CNAMEs, and also means that when multiple hosts have the
 -- same alias, a DNS round-robin is automatically set up.
-alias :: Domain -> Property
+alias :: Domain -> Property HasInfo
 alias d = pureInfoProperty ("alias " ++ d) $ mempty
 	{ _aliases = S.singleton d
 	-- A CNAME is added here, but the DNS setup code converts it to an
@@ -55,7 +55,7 @@ alias d = pureInfoProperty ("alias " ++ d) $ mempty
 	, _dns = S.singleton $ CNAME $ AbsDomain d
 	} 
 
-addDNS :: Record -> Property
+addDNS :: Record -> Property HasInfo
 addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }
   where
 	rdesc (CNAME d) = unwords ["alias", ddesc d]

src/Propellor/Types.hs

@@ -2,24 +2,31 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 module Propellor.Types
 	( Host(..)
 	, Property(..)
+	, HasInfo
+	, NoInfo
+	, Desc
 	, mkProperty
 	, propertyDesc
 	, propertySatisfy
 	, propertyInfo
 	, propertyChildren
 	, RevertableProperty(..)
+	, mkRevertableProperty
+	, requires
 	, IsProp(..)
-	, Desc
 	, Info(..)
 	, Propellor(..)
 	, EndAction(..)
 	, module Propellor.Types.OS
 	, module Propellor.Types.Dns
 	, module Propellor.Types.Result
+	, ignoreInfo
 	) where
 
 import Data.Monoid
@@ -43,7 +50,7 @@ import qualified Propellor.Types.Dns as Dns
 -- properties and their collected info.
 data Host = Host
 	{ hostName :: HostName
-	, hostProperties :: [Property]
+	, hostProperties :: [Property HasInfo]
 	, hostInfo :: Info
 	}
 	deriving (Show)
@@ -65,96 +72,134 @@ newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
 -- properties. It's passed the combined Result of the entire Propellor run.
 data EndAction = EndAction Desc (Result -> Propellor Result)
 
+type Desc = String
+
 -- | The core data type of Propellor, this represents a property
 -- that the system should have, and an action to ensure it has the
 -- property.
-data Property = IProperty (GProperty HasInfo) | SProperty (GProperty NoInfo)
+data Property i where
+	IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo
+	SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
+
+data HasInfo
+data NoInfo
 
 -- | Constructs a Property
 mkProperty 
 	:: Desc -- ^ description of the property
 	-> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly)
 	-> Info -- ^ info associated with the property
-	-> [Property] -- ^ child properties
+	-> [Property i] -- ^ child properties
-	-> Property
+	-> Property HasInfo
-mkProperty d a i cs
+mkProperty d a i cs = IProperty d a i (map toIProperty cs)
-	| isEmpty i && all isEmpty (map propertyInfo cs) = 
-		SProperty (GSProperty d a cs)
-	| otherwise = IProperty (GIProperty d a i cs)
 
-instance Show Property where
+toIProperty :: Property i -> Property HasInfo
+toIProperty p@(IProperty {}) = p
+toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs)
+
+toSProperty :: Property i -> Property NoInfo
+toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs)
+toSProperty p@(SProperty {}) = p
+
+-- | Makes a version of a Proprty without its Info.
+-- Use with caution!
+ignoreInfo :: Property HasInfo -> Property NoInfo
+ignoreInfo = toSProperty
+
+instance Show (Property i) where
         show p = "property " ++ show (propertyDesc p)
 
--- | This GADT allows creating operations that only act on Properties
+propertyDesc :: Property i -> Desc
--- that do not add Info to their Host.
+propertyDesc (IProperty d _ _ _) = d
-data GProperty i where
+propertyDesc (SProperty d _ _) = d
-	GIProperty :: Desc -> Propellor Result -> Info -> [Property] -> GProperty HasInfo
-	GSProperty :: Desc -> Propellor Result -> [Property] -> GProperty NoInfo
 
-data HasInfo
+propertySatisfy :: Property i -> Propellor Result
-data NoInfo
+propertySatisfy (IProperty _ a _ _) = a
+propertySatisfy (SProperty _ a _) = a
 
-propertyDesc :: Property -> Desc
+propertyInfo :: Property i -> Info
-propertyDesc (IProperty (GIProperty d _ _ _)) = d
+propertyInfo (IProperty _ _ i _) = i
-propertyDesc (SProperty (GSProperty d _ _)) = d
+propertyInfo (SProperty {}) = mempty
-
-propertySatisfy :: Property -> Propellor Result
-propertySatisfy (IProperty (GIProperty _ a _ _)) = a
-propertySatisfy (SProperty (GSProperty _ a _)) = a
-
-propertyInfo :: Property -> Info
-propertyInfo (IProperty (GIProperty _ _ i _)) = i
-propertyInfo (SProperty _) = mempty
 
 -- | A Property can include a list of child properties that it also
 -- satisfies. This allows them to be introspected to collect their info, etc.
-propertyChildren :: Property -> [Property]
+propertyChildren :: Property i -> [Property i]
-propertyChildren (IProperty (GIProperty _ _ _ cs)) = cs
+propertyChildren (IProperty _ _ _ cs) = cs
-propertyChildren (SProperty (GSProperty _ _ cs)) = cs
+propertyChildren (SProperty _ _ cs) = cs
 
 -- | A property that can be reverted.
-data RevertableProperty = RevertableProperty Property Property
+data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo)
+
+mkRevertableProperty :: Property i1 -> Property i2 -> RevertableProperty
+mkRevertableProperty p1 p2 = RevertableProperty (toIProperty p1) (toIProperty p2)
 
 class IsProp p where
 	-- | Sets description.
 	describe :: p -> Desc -> p
-	toProp :: p -> Property
+	toProp :: p -> Property HasInfo
-	-- | Indicates that the first property can only be satisfied
-	-- once the second one is.
-	requires :: p -> Property -> p
 	-- | Gets the info of the property, combined with all info
 	-- of all children properties.
 	getInfoRecursive :: p -> Info
 
-instance IsProp Property where
+instance IsProp (Property HasInfo) where
-	describe (IProperty (GIProperty _ a i cs)) d = 
+	describe (IProperty _ a i cs) d = IProperty d a i cs
-		IProperty (GIProperty d a i cs)
+	toProp = id
-	describe (SProperty (GSProperty _ a cs)) d =
+	getInfoRecursive (IProperty _ _ i cs) = 
-		SProperty (GSProperty d a cs)
-	toProp p = p
-	getInfoRecursive (IProperty (GIProperty _ _ i cs)) = 
 		i <> mconcat (map getInfoRecursive cs)
-	getInfoRecursive (SProperty _) = mempty
+instance IsProp (Property NoInfo) where
-	x `requires` y = mkProperty (propertyDesc x) satisfy (propertyInfo x) cs
+	describe (SProperty _ a cs) d = SProperty d a cs
-	  where
+	toProp = toIProperty
-		satisfy = do
+	getInfoRecursive _ = mempty
-			r <- propertySatisfy y
-			case r of
-				FailedChange -> return FailedChange
-				_ -> propertySatisfy x
-		cs = y : propertyChildren x
 
 instance IsProp RevertableProperty where
 	-- | Sets the description of both sides.
 	describe (RevertableProperty p1 p2) d = 
 		RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
 	toProp (RevertableProperty p1 _) = p1
-	(RevertableProperty p1 p2) `requires` y =
-		RevertableProperty (p1 `requires` y) p2
 	-- | Return the Info of the currently active side.
 	getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
 
-type Desc = String
+class Requires x y r where
+	-- Indicates that the first property depends on the second,
+	-- so before the first is ensured, the second will be ensured.
+	requires :: x -> y -> r
+
+instance Requires (Property HasInfo) (Property HasInfo) (Property HasInfo) where
+	requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
+		IProperty d1 (a2 `andThen` a1) i1 (y : cs1)
+
+instance Requires (Property HasInfo) (Property NoInfo) (Property HasInfo) where
+	requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
+		IProperty d1 (a2 `andThen` a1) i1 (toIProperty y : cs1)
+
+instance Requires (Property NoInfo) (Property HasInfo) (Property HasInfo) where
+	requires x y = requires y x
+
+instance Requires (Property NoInfo) (Property NoInfo) (Property NoInfo) where
+	requires (SProperty d1 a1  cs1) y@(SProperty _d2 a2 _cs2) =
+		SProperty d1 (a2 `andThen` a1) (y : cs1)
+
+instance Requires RevertableProperty (Property HasInfo) RevertableProperty where
+	requires (RevertableProperty p1 p2) y =
+		RevertableProperty (p1 `requires` y) p2
+
+instance Requires RevertableProperty (Property NoInfo) RevertableProperty where
+	requires (RevertableProperty p1 p2) y =
+		RevertableProperty (p1 `requires` toIProperty y) p2
+
+instance Requires RevertableProperty RevertableProperty RevertableProperty where
+	requires (RevertableProperty x1 x2) (RevertableProperty y1 y2) =
+		RevertableProperty
+			(x1 `requires` y1)
+			-- when reverting, run actions in reverse order
+			(y2 `requires` x2)
+
+andThen :: Propellor Result -> Propellor Result -> Propellor Result
+x `andThen` y = do
+	r <- x
+	case r of
+		FailedChange -> return FailedChange
+		_ -> y
 
 -- | Information about a host.
 data Info = Info