From b3689108a788eee628b15a032391df294115237e Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Wed, 14 Jan 2026 21:50:47 +0100 Subject: [PATCH] Introduce ensurePartOfDayIs --- .../InteractionListGenerators.fs | 18 +++++++++++ NightLight.Core.Tests/NightLightTests.fs | 28 +++++++--------- .../TimeChangedGenerators.fs | 32 ++++++++++--------- 3 files changed, 46 insertions(+), 32 deletions(-) diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index 9c18e45..a431f96 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -49,3 +49,21 @@ let ensureLightHasPower (light: Light) (genInteractions: Gen) interactions else interactions @ [ HumanInteraction(LightPoweredOn light) ]) + +let ensurePartOfDayIs (desiredPartOfDay: PartOfDay) (genInteractions: Gen) = + genInteractions + |> Gen.bind (fun interactions -> + let maybeActualTime = + interactions + |> Seq.choose (fun interaction -> + match interaction with + | Interaction.TimeChanged time -> Some time + | _ -> None) + |> Seq.tryLast + + if maybeActualTime |> Option.map getPartOfDay = Some desiredPartOfDay then + Gen.constant interactions + else + desiredPartOfDay + |> genTimeChangedToPartOfDay + |> Gen.map (fun tc -> interactions @ [ tc ])) diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index c9ceaa9..6320b95 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -27,10 +27,8 @@ type NightLightTests() = [ |])>] let ``All lights should be either off, white or yellow during the day`` (light: Light) = - concatGens - [ genRandomInteractions light - genTimeChangedToRandomDayTime |> Gen.map List.singleton - genRandomInteractionsExcept light isTimeChangedToAnyNightTime ] + genRandomInteractions light + |> ensurePartOfDayIs Day |> ensureStartsWithTimeChanged |> Arb.fromGen |> Prop.forAll @@ -43,10 +41,8 @@ type NightLightTests() = [ |])>] let ``All lights should be either off or red during the night`` (light: Light) = - concatGens - [ genRandomInteractions light - genTimeChangedToRandomNightTime |> Gen.map List.singleton - genRandomInteractionsExcept light isTimeChangedToAnyDayTime ] + genRandomInteractions light + |> ensurePartOfDayIs Night |> ensureStartsWithTimeChanged |> Arb.fromGen |> Prop.forAll @@ -60,8 +56,8 @@ type NightLightTests() = [ |])>] let ``All non-remotely controlled lights with power should be on`` (light: Light) = genRandomInteractions light - |> ensureStartsWithTimeChanged |> ensureLightHasPower light + |> ensureStartsWithTimeChanged |> Arb.fromGen |> Prop.forAll <| fun interactions -> @@ -71,8 +67,8 @@ type NightLightTests() = [ |])>] let ``All remote controlled lights with power should be on if the remote was never used`` (light: Light) = genRandomInteractionsExcept light _.IsRemoteInteraction - |> ensureStartsWithTimeChanged |> ensureLightHasPower light + |> ensureStartsWithTimeChanged |> Arb.fromGen |> Prop.forAll <| fun interactions -> @@ -87,8 +83,8 @@ type NightLightTests() = [ genRandomInteractions light RemoteInteraction RemotePressedOnButton |> List.singleton |> Gen.constant genRandomInteractionsExcept light _.IsRemoteInteraction ] - |> ensureStartsWithTimeChanged |> ensureLightHasPower light + |> ensureStartsWithTimeChanged |> Arb.fromGen |> Prop.forAll <| fun interactions -> @@ -100,10 +96,8 @@ type NightLightTests() = (light: Light) = concatGens - [ genRandomInteractions light - genTimeChangedToRandomNightTime |> Gen.map List.singleton - genRandomInteractionsExcept light isTimeChangedToAnyDayTime - genTimeChangedToRandomDayTime |> Gen.map List.singleton + [ genRandomInteractions light |> ensurePartOfDayIs Night + genTimeChangedToPartOfDay Day |> Gen.map List.singleton genRandomInteractionsExcept light _.IsRemoteInteraction ] |> ensureStartsWithTimeChanged |> ensureLightHasPower light @@ -121,7 +115,7 @@ type NightLightTests() = [ genRandomInteractions light RemoteInteraction RemotePressedOffButton |> List.singleton |> Gen.constant genRandomInteractionsExcept light (fun interaction -> - interaction.IsRemoteInteraction || interaction |> isTimeChangedToAnyDayTime) ] + interaction.IsRemoteInteraction || interaction |> isTimeChangedToPartOfDay Day) ] |> ensureStartsWithTimeChanged |> Arb.fromGen |> Prop.forAll @@ -153,7 +147,7 @@ type NightLightTests() = [ genRandomInteractions light RemoteInteraction RemotePressedLeftButton |> List.singleton |> Gen.constant genRandomInteractionsExcept light (fun interaction -> - interaction.IsRemoteInteraction || interaction |> isTimeChangedToAnyDayTime) ] + interaction.IsRemoteInteraction || interaction |> isTimeChangedToPartOfDay Day) ] |> ensureStartsWithTimeChanged |> Arb.fromGen |> Prop.forAll diff --git a/NightLight.Core.Tests/TimeChangedGenerators.fs b/NightLight.Core.Tests/TimeChangedGenerators.fs index 7ab279a..64aa619 100644 --- a/NightLight.Core.Tests/TimeChangedGenerators.fs +++ b/NightLight.Core.Tests/TimeChangedGenerators.fs @@ -3,24 +3,26 @@ module NightLight.Core.Tests.TimeChangedGenerators open System open FsCheck.FSharp -let private isDay (time: DateTime) = - time.TimeOfDay >= TimeSpan.FromHours 6 - && time.TimeOfDay < TimeSpan.FromHours 20.5 +type PartOfDay = + | Day + | Night -let private isTimeChangedMeetingCondition condition interaction = - match interaction with - | TimeChanged time when condition time -> true - | _ -> false - -let isTimeChangedToAnyDayTime = isTimeChangedMeetingCondition isDay - -let isTimeChangedToAnyNightTime = isTimeChangedMeetingCondition (not << isDay) +let getPartOfDay (dateTime: DateTime) = + match dateTime with + | _ when + dateTime.TimeOfDay >= TimeSpan.FromHours 6 + && dateTime.TimeOfDay < TimeSpan.FromHours 20.5 + -> + Day + | _ -> Night let genTimeChanged = ArbMap.defaults |> ArbMap.generate |> Gen.map Interaction.TimeChanged -let genTimeChangedToRandomDayTime = - genTimeChanged |> Gen.filter isTimeChangedToAnyDayTime +let isTimeChangedToPartOfDay partOfDay interaction = + match interaction with + | TimeChanged time when getPartOfDay time = partOfDay -> true + | _ -> false -let genTimeChangedToRandomNightTime = - genTimeChanged |> Gen.filter isTimeChangedToAnyNightTime +let genTimeChangedToPartOfDay (partOfDay: PartOfDay) = + genTimeChanged |> Gen.filter (isTimeChangedToPartOfDay partOfDay)