Skip to content

Commit 0036d91

Browse files
sd234678sd234678
committed
Add TH to config code to reduce manual work when adding new config versions
1 parent 49873df commit 0036d91

File tree

5 files changed

+219
-98
lines changed

5 files changed

+219
-98
lines changed

‎.last-exported-commit‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
Last exported commit from parent repo: 552c745ab5a9b608d81f0ded5c13df6164ebb15b
1+
Last exported commit from parent repo: 6e8a276ef9ff4365202515e0b11f27978f42d077

‎nix-bootstrap.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,7 +56,9 @@ library
5656
Bootstrap.Data.BuildPlan
5757
Bootstrap.Data.Config
5858
Bootstrap.Data.Config.Internal
59+
Bootstrap.Data.Config.Internal.CurrentVersion
5960
Bootstrap.Data.Config.Internal.TH
61+
Bootstrap.Data.Config.Internal.THHelpers
6062
Bootstrap.Data.ContinuousIntegration
6163
Bootstrap.Data.DevContainer
6264
Bootstrap.Data.GHCVersion

‎src/Bootstrap/Data/Config/Internal.hs‎

Lines changed: 179 additions & 97 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,11 @@ import Bootstrap.Data.Bootstrappable.BootstrapState
3434
),
3535
bootstrapStateCodec,
3636
)
37+
import Bootstrap.Data.Config.Internal.CurrentVersion
38+
( currentVersionNumber,
39+
versionUniverse,
40+
)
41+
import Bootstrap.Data.Config.Internal.THHelpers (isoForName)
3742
import Bootstrap.Data.ContinuousIntegration
3843
( ContinuousIntegrationConfig,
3944
)
@@ -61,8 +66,8 @@ import Bootstrap.Data.ProjectType
6166
)
6267
import Bootstrap.Data.Target (Target (TargetDefault))
6368
import Bootstrap.Monad (MonadBootstrap)
64-
import Control.Lens (Iso', iso, makeLenses)
65-
import Control.Monad.Catch (MonadThrow (throwM), catchAll, handleAll)
69+
import Control.Lens (Iso', makeLenses)
70+
import Control.Monad.Catch (MonadCatch, MonadThrow (throwM), catchAll, handleAll)
6671
import Data.Singletons
6772
( Sing,
6873
SingI (sing),
@@ -89,65 +94,105 @@ import Dhall.Deriving
8994
type (<<<),
9095
)
9196
import Dhall.Src (Src)
97+
import qualified Language.Haskell.TH as TH
9298
import System.Directory (doesFileExist)
9399
import System.Terminal (MonadPrinter (putTextLn))
94100
import Text.Show (Show (show))
95101
import qualified Toml as TOML
96102

97-
-- | The version of `Config` being used
98-
data ConfigVersion
99-
= V1
100-
| V2
101-
| V3
102-
| V4
103-
| V5
104-
| V6
105-
| V7
106-
| V8
107-
| V9
108-
109-
-- | Singled `ConfigVersion`
110-
data SConfigVersion (configVersion :: ConfigVersion) where
111-
SV1 :: SConfigVersion 'V1
112-
SV2 :: SConfigVersion 'V2
113-
SV3 :: SConfigVersion 'V3
114-
SV4 :: SConfigVersion 'V4
115-
SV5 :: SConfigVersion 'V5
116-
SV6 :: SConfigVersion 'V6
117-
SV7 :: SConfigVersion 'V7
118-
SV8 :: SConfigVersion 'V8
119-
SV9 :: SConfigVersion 'V9
103+
{-
104+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
105+
Adding a new config version?
106+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
107+
108+
The first thing to do is update currentVersionNumber in Bootstrap.Data.Config.Internal.CurrentVersion.
109+
Then come back here and start following the compiler errors.
110+
-}
111+
112+
{- data ConfigVersion = V1 | V2 | ...
113+
114+
Creates constructors up to (including) `currentVersionNumber` -}
115+
$( TH.newName "ConfigVersion" >>= \decName ->
116+
one
117+
<$> TH.dataD_doc
118+
(pure [])
119+
decName
120+
[]
121+
Nothing
122+
(versionUniverse <&> \n -> ((`TH.NormalC` []) <$> TH.newName ('V' : Prelude.show n), Nothing, []))
123+
[]
124+
(Just "The version of `Config` being used")
125+
)
126+
127+
-- Singled `ConfigVersion`
128+
$( TH.newName "SConfigVersion" >>= \decName -> do
129+
let makeCon n = do
130+
conName <- TH.newName ("SV" <> Prelude.show n)
131+
Just unsingled <- TH.lookupValueName ('V' : Prelude.show n)
132+
TH.gadtC [conName] [] (pure $ TH.AppT (TH.ConT decName) (TH.PromotedT unsingled))
133+
one
134+
<$> TH.dataD_doc
135+
(pure [])
136+
decName
137+
[TH.newName "configVersion" <&> \name -> TH.KindedTV name TH.BndrReq (TH.ConT ''ConfigVersion)]
138+
Nothing
139+
(versionUniverse <&> \n -> (makeCon n, Nothing, []))
140+
[]
141+
(Just "Singled `ConfigVersion`")
142+
)
120143

121144
type instance Sing = SConfigVersion
122145

123-
instance SingKind ConfigVersion where
124-
type Demote ConfigVersion = ConfigVersion
125-
fromSing = \case
126-
SV1 -> V1
127-
SV2 -> V2
128-
SV3 -> V3
129-
SV4 -> V4
130-
SV5 -> V5
131-
SV6 -> V6
132-
SV7 -> V7
133-
SV8 -> V8
134-
SV9 -> V9
135-
toSing = \case
136-
V1 -> SomeSing SV1
137-
V2 -> SomeSing SV2
138-
V3 -> SomeSing SV3
139-
V4 -> SomeSing SV4
140-
V5 -> SomeSing SV5
141-
V6 -> SomeSing SV6
142-
V7 -> SomeSing SV7
143-
V8 -> SomeSing SV8
144-
V9 -> SomeSing SV9
145-
146-
-- | The most recent version of the config
147-
type Current = 'V9
148-
149-
instance SingI Current where
150-
sing = SV9
146+
-- Instance of SingKind ConfigVersion
147+
$( do
148+
Just fromSingName <- TH.lookupValueName "fromSing"
149+
Just toSingName <- TH.lookupValueName "toSing"
150+
one
151+
<$> TH.instanceD
152+
(pure [])
153+
[t|SingKind ConfigVersion|]
154+
[ TH.tySynInstD (TH.tySynEqn Nothing [t|Demote ConfigVersion|] [t|ConfigVersion|]),
155+
TH.funD fromSingName $
156+
versionUniverse <&> \n ->
157+
do
158+
Just sv <- TH.lookupValueName $ "SV" <> Prelude.show n
159+
Just v <- TH.lookupValueName $ "V" <> Prelude.show n
160+
pure $ TH.Clause [TH.ConP sv [] []] (TH.NormalB $ TH.ConE v) [],
161+
TH.funD
162+
toSingName
163+
$ versionUniverse <&> \n -> do
164+
Just someSing <- TH.lookupValueName "SomeSing"
165+
Just sv <- TH.lookupValueName $ "SV" <> Prelude.show n
166+
Just v <- TH.lookupValueName $ "V" <> Prelude.show n
167+
pure $ TH.Clause [TH.ConP v [] []] (TH.NormalB $ TH.ConE someSing `TH.AppE` TH.ConE sv) []
168+
]
169+
)
170+
171+
-- Type synonym for Vx, where x is `currentVersionNumber`
172+
$( TH.newName "Current" >>= \decName ->
173+
one
174+
<$> TH.withDecDoc
175+
"The most recent version of the config"
176+
( TH.tySynD
177+
decName
178+
[]
179+
do
180+
Just current <- TH.lookupValueName $ 'V' : Prelude.show currentVersionNumber
181+
pure $ TH.PromotedT current
182+
)
183+
)
184+
185+
-- Instance of SingI for the current config version
186+
$( one
187+
<$> TH.instanceD
188+
(pure [])
189+
[t|SingI Current|]
190+
[ do
191+
Just singName <- TH.lookupValueName "sing"
192+
Just svCurrent <- TH.lookupValueName $ "SV" <> Prelude.show currentVersionNumber
193+
TH.funD singName [pure $ TH.Clause [] (TH.NormalB $ TH.ConE svCurrent) []]
194+
]
195+
)
151196

152197
-- | nix-bootstrap's configuration
153198
type Config = VersionedConfig Current
@@ -322,8 +367,15 @@ versionedProjectTypeToDhall Proxy unwrap normaliser =
322367
where
323368
Encoder {..} = injectWith @underlying normaliser
324369

370+
{- iso (\(VPT9 x) -> x) VPT9
371+
(or whatever the current version is)
372+
-}
325373
_VersionedProjectType :: Iso' (VersionedProjectType Current) ProjectType
326-
_VersionedProjectType = iso (\(VPT9 x) -> x) VPT9
374+
_VersionedProjectType =
375+
$( do
376+
Just vptCurrentName <- TH.lookupValueName $ "VPT" <> Prelude.show currentVersionNumber
377+
isoForName vptCurrentName
378+
)
327379

328380
-- | The location of a bootstrapped config file
329381
configPath :: FilePath
@@ -336,30 +388,6 @@ newtype TomlDecodeException = TomlDecodeException {unTomlDecodeException :: [TOM
336388
instance Exception TomlDecodeException where
337389
displayException = toString . TOML.prettyTomlDecodeErrors . unTomlDecodeException
338390

339-
-- | Parses the given text as a nix-bootstrap config file
340-
parseVersionedConfig ::
341-
forall m version.
342-
(MonadBootstrap m) =>
343-
SConfigVersion version ->
344-
Text ->
345-
m (Either SomeException (VersionedConfig version))
346-
parseVersionedConfig v s = case v of
347-
SV1 ->
348-
pure
349-
. bimap (SomeException . TomlDecodeException) VersionedConfigV1
350-
$ TOML.decode bootstrapStateCodec s
351-
SV2 -> parseFor VersionedConfigV2
352-
SV3 -> parseFor VersionedConfigV3
353-
SV4 -> parseFor VersionedConfigV4
354-
SV5 -> parseFor VersionedConfigV5
355-
SV6 -> parseFor VersionedConfigV6
356-
SV7 -> parseFor VersionedConfigV7
357-
SV8 -> parseFor VersionedConfigV8
358-
SV9 -> parseFor VersionedConfigV9
359-
where
360-
parseFor :: (FromDhall config) => (config -> versionedConfig) -> m (Either SomeException versionedConfig)
361-
parseFor constructor = handleAll (pure . Left) . fmap (Right . constructor) . liftIO $ input auto s
362-
363391
-- | The second version of the config
364392
data ConfigV2 = ConfigV2
365393
{ _configV2ProjectName :: ProjectName,
@@ -428,6 +456,46 @@ deriving stock instance (Eq (VersionedProjectType 'V9)) => Eq ConfigV9
428456

429457
deriving stock instance (Show (VersionedProjectType 'V9)) => Show ConfigV9
430458

459+
-- | Used by parseVersionConfig to parse when the version is known statically
460+
parseVersionedConfigFor ::
461+
(FromDhall config, MonadCatch m, MonadIO m) =>
462+
(config -> versionedConfig) ->
463+
Text ->
464+
m (Either SomeException versionedConfig)
465+
parseVersionedConfigFor constructor contents = handleAll (pure . Left) . fmap (Right . constructor) . liftIO $ input auto contents
466+
467+
-- | Parses the given text as a nix-bootstrap config file
468+
parseVersionedConfig ::
469+
forall m version.
470+
(MonadBootstrap m) =>
471+
SConfigVersion version ->
472+
Text ->
473+
m (Either SomeException (VersionedConfig version))
474+
parseVersionedConfig v contents =
475+
$( TH.caseE [|v|] $
476+
( do
477+
pat <- [p|SV1|]
478+
body <-
479+
TH.NormalB
480+
<$> [|
481+
pure
482+
. bimap (SomeException . TomlDecodeException) VersionedConfigV1
483+
$ TOML.decode bootstrapStateCodec contents
484+
|]
485+
pure $ TH.Match pat body []
486+
)
487+
: ( [2 .. currentVersionNumber] <&> \n -> do
488+
Just svName <- TH.lookupValueName $ "SV" <> Prelude.show n
489+
Just vcName <- TH.lookupValueName $ "VersionedConfigV" <> Prelude.show n
490+
body <-
491+
TH.NormalB
492+
<$> TH.appE
493+
(TH.appE [|parseVersionedConfigFor|] (pure $ TH.ConE vcName))
494+
[|contents|]
495+
pure $ TH.Match (TH.ConP svName [] []) body []
496+
)
497+
)
498+
431499
-- | An exception thrown when a config specifies that flakes are not to be used;
432500
-- this is an exception because non-flake support has been withdrawn and migration
433501
-- to flakes is not automatic.
@@ -454,11 +522,23 @@ data LoadConfigResult
454522

455523
deriving stock instance (Show Config) => Show LoadConfigResult
456524

457-
makeLenses ''ConfigV9
458-
459-
-- | Isomorphism to the current config version
460-
_Current :: Iso' Config ConfigV9
461-
_Current = iso (\(VersionedConfigV9 c) -> c) VersionedConfigV9
525+
$( do
526+
Just nameToMakeLensesFor <- TH.lookupTypeName $ "ConfigV" <> Prelude.show currentVersionNumber
527+
makeLenses nameToMakeLensesFor
528+
)
529+
530+
{- _Current :: Iso' Config ConfigV9
531+
_Current = iso (\(VersionedConfigV9 c) -> c) VersionedConfigV9
532+
(or whatever the current version is)
533+
-}
534+
$( do
535+
decName <- TH.newName "_Current"
536+
Just configVxTypeName <- TH.lookupTypeName $ "ConfigV" <> Prelude.show currentVersionNumber
537+
Just versionedConfigName <- TH.lookupValueName $ "VersionedConfigV" <> Prelude.show currentVersionNumber
538+
sigD <- TH.sigD decName $ [t|Iso' Config|] `TH.appT` TH.conT configVxTypeName
539+
funD <- TH.funD_doc decName [TH.clause [] (TH.NormalB <$> isoForName versionedConfigName) []] (Just "Isomorphism to the current config version") []
540+
pure [sigD, funD]
541+
)
462542

463543
-- | Loads the config from the appropriate file
464544
loadConfig :: (MonadBootstrap m) => m LoadConfigResult
@@ -472,20 +552,22 @@ loadConfig' nextToTry = do
472552
Right Nothing -> pure LoadConfigResultNotFound
473553
Right (Just c) -> pure $ LoadConfigResultFound c
474554
Left e -> tryPreviousConfigVersion e nextToTry
475-
where
476-
tryPreviousConfigVersion :: SomeException -> SConfigVersion v -> m LoadConfigResult
477-
tryPreviousConfigVersion e v = case fromException e of
478-
Just NonFlakeConfigException -> pure $ LoadConfigResultError e
479-
Nothing -> case v of
480-
SV9 -> loadConfig' SV8
481-
SV8 -> loadConfig' SV7
482-
SV7 -> loadConfig' SV6
483-
SV6 -> loadConfig' SV5
484-
SV5 -> loadConfig' SV4
485-
SV4 -> loadConfig' SV3
486-
SV3 -> loadConfig' SV2
487-
SV2 -> loadConfig' SV1
488-
SV1 -> pure $ LoadConfigResultError e
555+
556+
tryPreviousConfigVersion :: (MonadBootstrap m) => SomeException -> SConfigVersion v -> m LoadConfigResult
557+
tryPreviousConfigVersion e v = case fromException e of
558+
Just NonFlakeConfigException -> pure $ LoadConfigResultError e
559+
Nothing ->
560+
$( TH.caseE [|v|] $
561+
(TH.Match <$> [p|SV1|] <*> (TH.NormalB <$> [|pure $ LoadConfigResultError e|]) <*> pure [])
562+
: ( [2 .. currentVersionNumber] <&> \n -> do
563+
Just svName <- TH.lookupValueName $ "SV" <> Prelude.show n
564+
Just previousSvName <- TH.lookupValueName $ "SV" <> Prelude.show (n - 1)
565+
body <-
566+
TH.NormalB
567+
<$> TH.appE [|loadConfig'|] (pure $ TH.ConE previousSvName)
568+
pure $ TH.Match (TH.ConP svName [] []) body []
569+
)
570+
)
489571

490572
-- | Loads and parses the config at the specified version.
491573
--

‎src/Bootstrap/Data/Config/Internal/CurrentVersion.hs‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
-- | Copyright : (c) Crown Copyright GCHQ
2+
-- Description : Defines the most recent config version, from which
3+
-- many of the config types are generated.
4+
module Bootstrap.Data.Config.Internal.CurrentVersion (currentVersionNumber, versionUniverse) where
5+
6+
-- | The most recent version of the config
7+
currentVersionNumber :: Int
8+
currentVersionNumber = 9
9+
10+
versionUniverse :: [Int]
11+
versionUniverse = [1 .. currentVersionNumber]

‎src/Bootstrap/Data/Config/Internal/THHelpers.hs‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
{-# LANGUAGE TemplateHaskellQuotes #-}
2+
3+
-- | Copyright : (c) Crown Copyright GCHQ
4+
-- Description : Common TH functions for use in ...Config.Internal
5+
module Bootstrap.Data.Config.Internal.THHelpers (isoForName) where
6+
7+
import Control.Lens (iso)
8+
import Language.Haskell.TH
9+
( ExpQ,
10+
Name,
11+
Quote (newName),
12+
appE,
13+
conE,
14+
conP,
15+
lamE,
16+
varE,
17+
varP,
18+
)
19+
20+
-- | Creates an iso like
21+
-- iso (\(VPT9 x) -> x) VPT9
22+
-- if VPT9 is the constructor name
23+
isoForName :: Name -> ExpQ
24+
isoForName constructorName = do
25+
x <- newName "x"
26+
[|iso|] `appE` lamE [conP constructorName [varP x]] (varE x) `appE` conE constructorName

0 commit comments

Comments
 (0)