From 56c3394144abbb9862dc67379d3253c76ae4df97 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 14:34:10 -0400 Subject: Explicit Info/NoInfo for RevertableProperty (API change) RevertableProperty used to be assumed to contain info, but this is now made explicit, with RevertableProperty HasInfo or RevertableProperty NoInfo. Transition guide: - If you define a RevertableProperty, expect some type check failures like: "Expecting one more argument to ‘RevertableProperty’". - Change it to "RevertableProperty NoInfo" - The compiler will then tell you if it needs "HasInfo" instead. - If you have code that uses the RevertableProperty constructor that fails to type check, use the more powerful operator --- src/Propellor/PropAccum.hs | 4 +- src/Propellor/Property.hs | 2 +- src/Propellor/Property/Apache.hs | 6 +- src/Propellor/Property/Apt.hs | 4 +- src/Propellor/Property/Chroot.hs | 4 +- src/Propellor/Property/Conductor.hs | 6 +- src/Propellor/Property/Debootstrap.hs | 2 +- src/Propellor/Property/DiskImage.hs | 8 +- src/Propellor/Property/Dns.hs | 8 +- src/Propellor/Property/DnsSec.hs | 4 +- src/Propellor/Property/Docker.hs | 2 +- src/Propellor/Property/Git.hs | 2 +- src/Propellor/Property/Nginx.hs | 2 +- src/Propellor/Property/Prosody.hs | 2 +- src/Propellor/Property/SiteSpecific/JoeySites.hs | 4 +- src/Propellor/Property/Ssh.hs | 2 +- src/Propellor/Property/Systemd.hs | 22 ++-- src/Propellor/Property/Uwsgi.hs | 2 +- src/Propellor/Types.hs | 130 ++++++++++++++++------- 19 files changed, 135 insertions(+), 81 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 3c50cf32..85a30af5 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, FlexibleContexts #-} module Propellor.PropAccum ( host @@ -46,7 +46,7 @@ class PropAccum h where (&^) = addPropFront -- | Adds a property in reverted form. -(!) :: PropAccum h => h -> RevertableProperty -> h +(!) :: IsProp (RevertableProperty i) => PropAccum h => h -> RevertableProperty i -> h h ! p = h & revert p infixl 1 & diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index d80d9c1f..e967cac9 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -201,7 +201,7 @@ withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo withOS desc a = property desc $ a =<< getOS -- | Undoes the effect of a RevertableProperty. -revert :: RevertableProperty -> RevertableProperty +revert :: RevertableProperty i -> RevertableProperty i revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 makeChange :: IO () -> Propellor Result diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs index 91b2e6a2..c2f49cff 100644 --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -16,7 +16,7 @@ reloaded = Service.reloaded "apache2" -- | A basic virtual host, publishing a directory, and logging to -- the combined apache log file. -virtualHost :: HostName -> Port -> FilePath -> RevertableProperty +virtualHost :: HostName -> Port -> FilePath -> RevertableProperty NoInfo virtualHost hn (Port p) docroot = siteEnabled hn [ "" , "ServerName "++hn++":"++show p @@ -30,7 +30,7 @@ virtualHost hn (Port p) docroot = siteEnabled hn type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty +siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo siteEnabled hn cf = enable disable where enable = combineProperties ("apache site enabled " ++ hn) @@ -59,7 +59,7 @@ siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $ where comment = "# deployed with propellor, do not modify" -modEnabled :: String -> RevertableProperty +modEnabled :: String -> RevertableProperty NoInfo modEnabled modname = enable disable where enable = check (not <$> isenabled) $ diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 14f170af..fd6230e8 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -212,7 +212,7 @@ autoRemove = runApt ["-y", "autoremove"] `describe` "apt autoremove" -- | Enables unattended upgrades. Revert to disable. -unattendedUpgrades :: RevertableProperty +unattendedUpgrades :: RevertableProperty NoInfo unattendedUpgrades = enable disable where enable = setup True @@ -272,7 +272,7 @@ data AptKey = AptKey , pubkey :: String } -trustsKey :: AptKey -> RevertableProperty +trustsKey :: AptKey -> RevertableProperty NoInfo trustsKey k = trustsKey' k untrustKey k trustsKey' :: AptKey -> Property NoInfo diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 771c4b99..20871a12 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -116,10 +116,10 @@ bootstrapped bootstrapper location = Chroot location bootstrapper h -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. -provisioned :: Chroot -> RevertableProperty +provisioned :: Chroot -> RevertableProperty HasInfo provisioned c = provisioned' (propagateChrootInfo c) c False -provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty +provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = (propigator $ propertyList (chrootDesc c "exists") [setup]) diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ed46601d..0d275b91 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -83,7 +83,7 @@ import qualified Data.Set as S -- | Class of things that can be conducted. class Conductable c where - conducts :: c -> RevertableProperty + conducts :: c -> RevertableProperty HasInfo instance Conductable Host where -- | Conduct the specified host. @@ -268,7 +268,7 @@ notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotCond where desc = "not " ++ cdesc (hostName h) -conductorKnownHost :: Host -> RevertableProperty +conductorKnownHost :: Host -> RevertableProperty NoInfo conductorKnownHost h = mk Ssh.knownHost @@ -290,7 +290,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h') -- Use this property to let the specified conductor ssh in and run propellor. -conductedBy :: Host -> RevertableProperty +conductedBy :: Host -> RevertableProperty NoInfo conductedBy h = (setup teardown) `describe` ("conducted by " ++ hostName h) where diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index f8981591..61912b32 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -98,7 +98,7 @@ extractSuite (System (Ubuntu r) _) = Just r -- When necessary, falls back to installing debootstrap from source. -- Note that installation from source is done by downloading the tarball -- from a Debian mirror, with no cryptographic verification. -installed :: RevertableProperty +installed :: RevertableProperty NoInfo installed = install remove where install = withOS "debootstrap installed" $ \o -> diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 90d0bcc6..5b8619ba 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -69,16 +69,16 @@ type DiskImage = FilePath -- Note that the disk image file is reused if it already exists, -- to avoid expensive IO to generate a new one. And, it's updated in-place, -- so its contents are undefined during the build process. -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageBuilt = imageBuilt' False -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed. -imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageBuilt' rebuild img mkchroot tabletype final partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot @@ -99,7 +99,7 @@ imageBuilt' rebuild img mkchroot tabletype final partspec = & Apt.cacheCleaned -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg where desc = img ++ " built from " ++ chrootdir diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 4c2f787f..adc12930 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -60,7 +60,7 @@ import Data.List -- -- In either case, the secondary dns server Host should have an ipv4 and/or -- ipv6 property defined. -primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty +primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo primary hosts domain soa rs = setup cleanup where setup = setupPrimary zonefile id hosts domain soa rs @@ -152,7 +152,7 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ -- This is different from the serial number used by 'primary', so if you -- want to later disable DNSSEC you will need to adjust the serial number -- passed to mkSOA to ensure it is larger. -signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty +signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo signedPrimary recurrance hosts domain soa rs = setup cleanup where setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") @@ -184,12 +184,12 @@ signedPrimary recurrance hosts domain soa rs = setup cleanup -- -- Note that if a host is declared to be a primary and a secondary dns -- server for the same domain, the primary server config always wins. -secondary :: [Host] -> Domain -> RevertableProperty +secondary :: [Host] -> Domain -> RevertableProperty HasInfo secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain -- | This variant is useful if the primary server does not have its DNS -- configured via propellor. -secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty +secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo secondaryFor masters hosts domain = setup cleanup where setup = pureInfoProperty desc (addNamedConf conf) diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs index c0aa1302..1ba459e6 100644 --- a/src/Propellor/Property/DnsSec.hs +++ b/src/Propellor/Property/DnsSec.hs @@ -7,7 +7,7 @@ import qualified Propellor.Property.File as File -- -- signedPrimary uses this, so this property does not normally need to be -- used directly. -keysInstalled :: Domain -> RevertableProperty +keysInstalled :: Domain -> RevertableProperty HasInfo keysInstalled domain = setup cleanup where setup = propertyList "DNSSEC keys installed" $ @@ -37,7 +37,7 @@ keysInstalled domain = setup cleanup -- -- signedPrimary uses this, so this property does not normally need to be -- used directly. -zoneSigned :: Domain -> FilePath -> RevertableProperty +zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo zoneSigned domain zonefile = setup cleanup where setup = check needupdate (forceZoneSigned domain zonefile) diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 394c4271..2b0e7e7e 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -123,7 +123,7 @@ container cn image = Container image (Host cn [] info) -- -- Reverting this property ensures that the container is stopped and -- removed. -docked :: Container -> RevertableProperty +docked :: Container -> RevertableProperty HasInfo docked ctr@(Container _ h) = (propagateContainerInfo ctr (go "docked" setup)) diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index d69fe250..8937d21a 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -11,7 +11,7 @@ import Data.List -- using git-daemon, run from inetd. -- -- Note that reverting this property does not remove or stop inetd. -daemonRunning :: FilePath -> RevertableProperty +daemonRunning :: FilePath -> RevertableProperty NoInfo daemonRunning exportdir = setup unsetup where setup = containsLine conf (mkl "tcp4") diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs index c9b4d8fd..c28dcc01 100644 --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -9,7 +9,7 @@ import qualified Propellor.Property.Service as Service type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty +siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo siteEnabled hn cf = enable disable where enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs index 0e379e63..f2d80ae4 100644 --- a/src/Propellor/Property/Prosody.hs +++ b/src/Propellor/Property/Prosody.hs @@ -11,7 +11,7 @@ type ConfigFile = [String] type Conf = String -confEnabled :: Conf -> ConfigFile -> RevertableProperty +confEnabled :: Conf -> ConfigFile -> RevertableProperty NoInfo confEnabled conf cf = enable disable where enable = dir `File.isSymlinkedTo` target diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 92903e9a..d6db6813 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -298,7 +298,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann , " " ] -apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty +apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty NoInfo apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile @@ -921,7 +921,7 @@ legacyWebSites = propertyList "legacy web sites" $ props , "rewriterule (.*) http://joeyh.name$1 [r]" ] -userDirHtml :: Property HasInfo +userDirHtml :: Property NoInfo userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf `onChange` Apache.reloaded `requires` Apache.modEnabled "userdir" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 60121336..304ed5cc 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -115,7 +115,7 @@ dotFile f user = do -- ports it is configured to listen on. -- -- Revert to prevent it listening on a particular port. -listenPort :: Int -> RevertableProperty +listenPort :: Int -> RevertableProperty NoInfo listenPort port = enable disable where portline = "Port " ++ show port diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 8761d842..42ff8e57 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -93,7 +93,7 @@ disabled n = trivial $ cmdProperty "systemctl" ["disable", n] `describe` ("service " ++ n ++ " disabled") -- | Masks a systemd service. -masked :: ServiceName -> RevertableProperty +masked :: ServiceName -> RevertableProperty NoInfo masked n = systemdMask systemdUnmask where systemdMask = trivial $ cmdProperty "systemctl" ["mask", n] @@ -206,7 +206,7 @@ container name system mkchroot = Container name c h -- -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. -nspawned :: Container -> RevertableProperty +nspawned :: Container -> RevertableProperty HasInfo nspawned c@(Container name (Chroot.Chroot loc builder _) h) = p `describe` ("nspawned " ++ name) where @@ -231,7 +231,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = -- | Sets up the service file for the container, and then starts -- it running. -nspawnService :: Container -> ChrootCfg -> RevertableProperty +nspawnService :: Container -> ChrootCfg -> RevertableProperty NoInfo nspawnService (Container name _ _) cfg = setup teardown where service = nspawnServiceName name @@ -282,7 +282,7 @@ nspawnServiceParams (SystemdNspawnCfg ps) = -- -- This uses nsenter to enter the container, by looking up the pid of the -- container's init process and using its namespace. -enterScript :: Container -> RevertableProperty +enterScript :: Container -> RevertableProperty NoInfo enterScript c@(Container name _ _) = setup teardown where setup = combineProperties ("generated " ++ enterScriptFile c) @@ -328,7 +328,7 @@ mungename = replace "/" "_" -- When there is no leading dash, "--" is prepended to the parameter. -- -- Reverting the property will remove a parameter, if it's present. -containerCfg :: String -> RevertableProperty +containerCfg :: String -> RevertableProperty HasInfo containerCfg p = RevertableProperty (mk True) (mk False) where mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $ @@ -340,18 +340,18 @@ containerCfg p = RevertableProperty (mk True) (mk False) -- | Bind mounts from the host into the container. -- -- This property is enabled by default. Revert it to disable it. -resolvConfed :: RevertableProperty +resolvConfed :: RevertableProperty HasInfo resolvConfed = containerCfg "bind=/etc/resolv.conf" -- | Link the container's journal to the host's if possible. -- (Only works if the host has persistent journal enabled.) -- -- This property is enabled by default. Revert it to disable it. -linkJournal :: RevertableProperty +linkJournal :: RevertableProperty HasInfo linkJournal = containerCfg "link-journal=try-guest" -- | Disconnect networking of the container from the host. -privateNetwork :: RevertableProperty +privateNetwork :: RevertableProperty HasInfo privateNetwork = containerCfg "private-network" class Publishable a where @@ -389,7 +389,7 @@ instance Publishable (Proto, Bound Port) where -- > & Systemd.running Systemd.networkd -- > & Systemd.publish (Port 80 ->- Port 8080) -- > & Apt.installedRunning "apache2" -publish :: Publishable p => p -> RevertableProperty +publish :: Publishable p => p -> RevertableProperty HasInfo publish p = containerCfg $ "--port=" ++ toPublish p class Bindable a where @@ -402,9 +402,9 @@ instance Bindable (Bound FilePath) where toBind v = hostSide v ++ ":" ++ containerSide v -- | Bind mount a file or directory from the host into the container. -bind :: Bindable p => p -> RevertableProperty +bind :: Bindable p => p -> RevertableProperty HasInfo bind p = containerCfg $ "--bind=" ++ toBind p -- | Read-only mind mount. -bindRo :: Bindable p => p -> RevertableProperty +bindRo :: Bindable p => p -> RevertableProperty HasInfo bindRo p = containerCfg $ "--bind-ro=" ++ toBind p diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs index 7de1a85a..9748f16d 100644 --- a/src/Propellor/Property/Uwsgi.hs +++ b/src/Propellor/Property/Uwsgi.hs @@ -11,7 +11,7 @@ type ConfigFile = [String] type AppName = String -appEnabled :: AppName -> ConfigFile -> RevertableProperty +appEnabled :: AppName -> ConfigFile -> RevertableProperty NoInfo appEnabled an cf = enable disable where enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 06f0935d..fa24786c 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -156,12 +156,6 @@ propertySatisfy :: Property i -> Propellor Result propertySatisfy (IProperty _ a _ _) = a propertySatisfy (SProperty _ a _) = a -instance Show (Property i) where - show p = "property " ++ show (propertyDesc p) - -instance Show RevertableProperty where - show (RevertableProperty p _) = "property " ++ show (propertyDesc p) - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs @@ -175,6 +169,9 @@ propertyDesc :: Property i -> Desc propertyDesc (IProperty d _ _ _) = d propertyDesc (SProperty d _ _) = d +instance Show (Property i) where + show p = "property " ++ show (propertyDesc p) + -- | 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 i -> [Property i] @@ -183,11 +180,23 @@ propertyChildren (SProperty _ _ cs) = cs -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. -data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo) +data RevertableProperty i = RevertableProperty (Property i) (Property i) + +instance Show (RevertableProperty i) where + show (RevertableProperty p _) = show p --- | Shorthand to construct a revertable property. -() :: Property i1 -> Property i2 -> RevertableProperty -p1 p2 = RevertableProperty (toIProperty p1) (toIProperty p2) +class MkRevertableProperty i1 i2 where + -- | Shorthand to construct a revertable property. + () :: Property i1 -> Property i2 -> RevertableProperty (CInfo i1 i2) + +instance MkRevertableProperty HasInfo HasInfo where + x y = RevertableProperty x y +instance MkRevertableProperty NoInfo NoInfo where + x y = RevertableProperty x y +instance MkRevertableProperty NoInfo HasInfo where + x y = RevertableProperty (toProp x) y +instance MkRevertableProperty HasInfo NoInfo where + x y = RevertableProperty x (toProp y) -- | Class of types that can be used as properties of a host. class IsProp p where @@ -210,35 +219,43 @@ instance IsProp (Property NoInfo) where getDesc = propertyDesc getInfoRecursive _ = mempty -instance IsProp RevertableProperty where - -- | Sets the description of both sides. - setDesc (RevertableProperty p1 p2) d = - RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) +instance IsProp (RevertableProperty HasInfo) where + setDesc = setDescR getDesc (RevertableProperty p1 _) = getDesc p1 toProp (RevertableProperty p1 _) = p1 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 +instance IsProp (RevertableProperty NoInfo) where + setDesc = setDescR + getDesc (RevertableProperty p1 _) = getDesc p1 + toProp (RevertableProperty p1 _) = toProp p1 + getInfoRecursive (RevertableProperty _ _) = mempty + +-- | Sets the description of both sides. +setDescR :: IsProp (Property i) => RevertableProperty i -> Desc -> RevertableProperty i +setDescR (RevertableProperty p1 p2) d = + RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) -- | Type level calculation of the type that results from combining two -- types of properties. type family CombinedType x y type instance CombinedType (Property x) (Property y) = Property (CInfo x y) -type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty +type instance CombinedType (RevertableProperty x) (RevertableProperty y) = RevertableProperty (CInfo x y) -- When only one of the properties is revertable, the combined property is -- not fully revertable, so is not a RevertableProperty. -type instance CombinedType RevertableProperty (Property NoInfo) = Property HasInfo -type instance CombinedType RevertableProperty (Property HasInfo) = Property HasInfo -type instance CombinedType (Property NoInfo) RevertableProperty = Property HasInfo -type instance CombinedType (Property HasInfo) RevertableProperty = Property HasInfo +type instance CombinedType (RevertableProperty x) (Property y) = Property (CInfo x y) +type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo x y) + +type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result class Combines x y where -- | Combines together two properties, yielding a property that -- has the description and info of the first, and that has the second -- property as a child. combineWith - :: (Propellor Result -> Propellor Result -> Propellor Result) + :: ResultCombiner -- ^ How to combine the actions to satisfy the properties. - -> (Propellor Result -> Propellor Result -> Propellor Result) + -> ResultCombiner -- ^ Used when combining revertable properties, to combine -- their reversion actions. -> x @@ -261,20 +278,57 @@ instance Combines (Property NoInfo) (Property NoInfo) where combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = SProperty d1 (f a1 a2) (y : cs1) -instance Combines RevertableProperty RevertableProperty where - combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = - RevertableProperty - (combineWith sf tf s1 s2) - (combineWith tf sf t1 t2) - -instance Combines RevertableProperty (Property HasInfo) where - combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y - -instance Combines RevertableProperty (Property NoInfo) where - combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y - -instance Combines (Property HasInfo) RevertableProperty where - combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y - -instance Combines (Property NoInfo) RevertableProperty where - combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y +instance Combines (RevertableProperty NoInfo) (RevertableProperty NoInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty HasInfo) (RevertableProperty HasInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty HasInfo) (RevertableProperty NoInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty NoInfo) (RevertableProperty HasInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty NoInfo) (Property HasInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty NoInfo) (Property NoInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty HasInfo) (Property HasInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty HasInfo) (Property NoInfo) where + combineWith = combineWithRP +instance Combines (Property HasInfo) (RevertableProperty NoInfo) where + combineWith = combineWithPR +instance Combines (Property NoInfo) (RevertableProperty NoInfo) where + combineWith = combineWithPR +instance Combines (Property HasInfo) (RevertableProperty HasInfo) where + combineWith = combineWithPR +instance Combines (Property NoInfo) (RevertableProperty HasInfo) where + combineWith = combineWithPR + +combineWithRR + :: Combines (Property x) (Property y) + => ResultCombiner + -> ResultCombiner + -> RevertableProperty x + -> RevertableProperty y + -> RevertableProperty (CInfo x y) +combineWithRR sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = + RevertableProperty + (combineWith sf tf s1 s2) + (combineWith tf sf t1 t2) + +combineWithRP + :: Combines (Property i) y + => (Propellor Result -> Propellor Result -> Propellor Result) + -> (Propellor Result -> Propellor Result -> Propellor Result) + -> RevertableProperty i + -> y + -> CombinedType (Property i) y +combineWithRP sf tf (RevertableProperty x _) y = combineWith sf tf x y + +combineWithPR + :: Combines x (Property i) + => (Propellor Result -> Propellor Result -> Propellor Result) + -> (Propellor Result -> Propellor Result -> Propellor Result) + -> x + -> RevertableProperty i + -> CombinedType x (Property i) +combineWithPR sf tf x (RevertableProperty y _) = combineWith sf tf x y -- cgit v1.2.3