From 64a9d4eeb4351484a8a97841cb82bf9041476eba Mon Sep 17 00:00:00 2001 From: Bernd Worsch Date: Fri, 10 Apr 2026 15:38:01 +0000 Subject: [PATCH] feat(WP-0016/C1-C4): Layer 2 isolation and clean-base infrastructure - Add Web/Controller/Prelude.hs (was missing; 8 controllers failed to import it) - Add .ghci-core and scripts/compile-check-core to compile Layer 1+2 in isolation without loading Main.hs or any controller/view (Layer 3) - Fix Application/Helper/BottleneckDetector.hs: replace coerce :: Id' -> UUID with unpackId (IHP Id' wraps a type family; Data.Coerce cannot cross it) - Fix devenv.nix: add pkgs.nodePackages.tailwindcss so devenv process scripts find the tailwindcss binary (devenv v2 builds scripts with only local packages) Co-Authored-By: Claude Sonnet 4.6 --- .ghci-core | 84 ++++++++++++++++++++++++ Application/Helper/BottleneckDetector.hs | 17 +++-- Web/Controller/Prelude.hs | 12 ++++ devenv.nix | 4 ++ scripts/compile-check-core | 20 ++++++ 5 files changed, 128 insertions(+), 9 deletions(-) create mode 100644 .ghci-core create mode 100644 Web/Controller/Prelude.hs create mode 100755 scripts/compile-check-core diff --git a/.ghci-core b/.ghci-core new file mode 100644 index 0000000..6da23b5 --- /dev/null +++ b/.ghci-core @@ -0,0 +1,84 @@ +-- .ghci-core — loads ONLY Layer 1 (Generated.Types, Web.Types) and Layer 2 +-- (Application/Helper/*) for independent compilation verification. +-- +-- Usage (inside devenv shell): +-- ghci -ghci-script .ghci-core +-- or: +-- ghcid --command "ghci -ghci-script .ghci-core" +-- +-- This file intentionally does NOT load Main.hs or any Web/Controller / Web/View +-- modules. Once this reaches "Ok, N modules loaded" with no errors, the core +-- layer is verified clean and Layer 3 errors are isolated to controllers/views. + +-- NOTE: we do NOT use :loadFromIHP applicationGhciConfig here because it ends +-- with ":l Main.hs" which would load all of Layer 3. Instead we duplicate +-- the environment flags from applicationGhciConfig and load only core modules. +:set -i. +:set -iIHP/ihp-hsx +:set -iConfig +:set -ibuild +:set -iIHP +:set -XOverloadedStrings +:set -XNoImplicitPrelude +:set -XImplicitParams +:set -XRank2Types +:set -XDisambiguateRecordFields +:set -XNamedFieldPuns +:set -XDuplicateRecordFields +:set -XOverloadedLabels +:set -XFlexibleContexts +:set -XTypeSynonymInstances +:set -XFlexibleInstances +:set -XQuasiQuotes +:set -XTypeFamilies +:set -XPackageImports +:set -XScopedTypeVariables +:set -XRecordWildCards +:set -XTypeApplications +:set -XDataKinds +:set -XInstanceSigs +:set -XDeriveGeneric +:set -XMultiParamTypeClasses +:set -XTypeOperators +:set -XUndecidableInstances +:set -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-safe -Wno-missing-local-signatures -Wno-missing-home-modules +:set -XDeriveDataTypeable +:set -XLambdaCase +:set -XDefaultSignatures +:set -XEmptyDataDeriving +:set -XBangPatterns +:set -XBlockArguments +:set -XMultiWayIf +:set -XFunctionalDependencies +:set -package ihp +:set -fbyte-code +:set -j1 +:set -fkeep-going +:set -Wno-partial-type-signatures +:set -XPartialTypeSignatures +:set -XStandaloneDeriving +:set -XDerivingVia +:set -XTemplateHaskell +:set -XDeepSubsumption +:set -XOverloadedRecordDot +:set -Werror=missing-fields +:set -fwarn-incomplete-patterns +:set -package ghc +:set -fno-warn-ambiguous-fields + +-- Layer 1: generated types and Web.Types +:load build/Generated/Types.hs Web/Types.hs Web/Routes.hs + +-- Layer 2: helpers (order matters — imports within Layer 2 must be satisfied) +:add Application/Helper/View.hs +:add Application/Helper/Controller.hs +:add Application/Helper/TypeRegistry.hs +:add Application/Helper/ModelRouter.hs +:add Application/Helper/RoutingEngine.hs +:add Application/Helper/FrictionScore.hs +:add Application/Helper/BottleneckDetector.hs +:add Application/Helper/HubHealth.hs +:add Application/Helper/CorrelationEngine.hs +:add Application/Helper/CrossHubPropagation.hs +:add Application/Helper/AgentBridge.hs +:add Application/Helper/ApiRateLimit.hs diff --git a/Application/Helper/BottleneckDetector.hs b/Application/Helper/BottleneckDetector.hs index 3767dd2..41a5558 100644 --- a/Application/Helper/BottleneckDetector.hs +++ b/Application/Helper/BottleneckDetector.hs @@ -8,7 +8,6 @@ import Generated.Types import Web.Routes () import Data.Time.Clock (addUTCTime, getCurrentTime, NominalDiffTime) import Database.PostgreSQL.Simple (Only(..)) -import Data.Coerce (coerce) -- | Severity based on how much older than the threshold the record is. staleSeverity :: NominalDiffTime -> NominalDiffTime -> Text @@ -47,7 +46,7 @@ detectBottlenecks hubId hubWidgets candidates requirements decisions deployments | c <- candidates , c.status == "open" , c.createdAt < addUTCTime (negate candidateThreshold) now - , c.id `notElem` map coerce existingSubjects + , unpackId c.id `notElem` existingSubjects ] -- Stage 2: requirements with no decision older than 60 days @@ -57,7 +56,7 @@ detectBottlenecks hubId hubWidgets candidates requirements decisions deployments | r <- requirements , r.createdAt < addUTCTime (negate requirementThreshold) now , r.id `notElem` linkedReqIds - , r.id `notElem` map coerce existingSubjects + , unpackId r.id `notElem` existingSubjects ] -- Stage 3: decisions with no deployment older than 30 days @@ -67,7 +66,7 @@ detectBottlenecks hubId hubWidgets candidates requirements decisions deployments | d <- decisions , d.decidedAt < addUTCTime (negate decisionThreshold) now , d.id `notElem` linkedDecisionIds - , d.id `notElem` map coerce existingSubjects + , unpackId d.id `notElem` existingSubjects ] -- Stage 4: deployments with no outcome signal older than 14 days @@ -80,7 +79,7 @@ detectBottlenecks hubId hubWidgets candidates requirements decisions deployments | dep <- deployments , dep.deployedAt < addUTCTime (negate observationThreshold) now , not (any (\wid -> wid `elem` signalWids) widgetIdSet) - , dep.id `notElem` map coerce existingSubjects + , unpackId dep.id `notElem` existingSubjects ] let mkBottleneck stage subjType subjId stalledSince threshold = do @@ -95,10 +94,10 @@ detectBottlenecks hubId hubWidgets candidates requirements decisions deployments |> set #severity severity |> createRecord - r1 <- mapM (\(c, t) -> mkBottleneck "candidate" "RequirementCandidate" (coerce c.id :: UUID) t candidateThreshold) staleCandidates - r2 <- mapM (\(r, t) -> mkBottleneck "requirement" "Requirement" (coerce r.id :: UUID) t requirementThreshold) stalRequirements - r3 <- mapM (\(d, t) -> mkBottleneck "decision" "DecisionRecord" (coerce d.id :: UUID) t decisionThreshold) staleDecisions - r4 <- mapM (\(d, t) -> mkBottleneck "observation" "DeploymentRecord" (coerce d.id :: UUID) t observationThreshold) staleDeployments + r1 <- mapM (\(c, t) -> mkBottleneck "candidate" "RequirementCandidate" (unpackId c.id) t candidateThreshold) staleCandidates + r2 <- mapM (\(r, t) -> mkBottleneck "requirement" "Requirement" (unpackId r.id) t requirementThreshold) stalRequirements + r3 <- mapM (\(d, t) -> mkBottleneck "decision" "DecisionRecord" (unpackId d.id) t decisionThreshold) staleDecisions + r4 <- mapM (\(d, t) -> mkBottleneck "observation" "DeploymentRecord" (unpackId d.id) t observationThreshold) staleDeployments pure (r1 <> r2 <> r3 <> r4) diff --git a/Web/Controller/Prelude.hs b/Web/Controller/Prelude.hs new file mode 100644 index 0000000..152730d --- /dev/null +++ b/Web/Controller/Prelude.hs @@ -0,0 +1,12 @@ +module Web.Controller.Prelude + ( module Web.Types + , module Generated.Types + , module IHP.Prelude + , module IHP.ControllerPrelude + ) where + +import Web.Types +import Generated.Types +import IHP.Prelude +import IHP.ControllerPrelude +import Web.Routes () diff --git a/devenv.nix b/devenv.nix index 9546679..1dc8a30 100644 --- a/devenv.nix +++ b/devenv.nix @@ -15,6 +15,10 @@ # GHC parallel module compilation is capped via -j1 in .ghci instead. env.GHCRTS = "-A32m -M2g"; + # Make tailwindcss available in process scripts (devenv v2 builds process + # scripts with only packages declared here, not from flake ihp.packages). + packages = [ pkgs.nodePackages.tailwindcss ]; + # Tailwind CSS watcher — not part of IHP's core devenv module. processes.tailwind.exec = "tailwindcss -c tailwind/tailwind.config.js -i ./tailwind/app.css -o static/app.css --watch=always"; } diff --git a/scripts/compile-check-core b/scripts/compile-check-core new file mode 100755 index 0000000..6c915ed --- /dev/null +++ b/scripts/compile-check-core @@ -0,0 +1,20 @@ +#!/usr/bin/env bash +# scripts/compile-check-core +# +# Verify Layer 1 + Layer 2 compile cleanly in isolation — WITHOUT loading +# any controller, view, or Main.hs. Use this to establish and confirm the +# clean base before working on Layer 3 (controllers/views). +# +# Usage (inside devenv shell): +# scripts/compile-check-core # interactive +# scripts/compile-check-core --bg # write to log only +# +# Once this reports "Ok, N modules loaded" with no errors, the core is clean. +set -euo pipefail +LOGFILE="${IHUB_COMPILE_LOG:-/tmp/ihub-core-errors.txt}" +: > "$LOGFILE" +echo "[compile-check-core] Writing to $LOGFILE" +exec ghcid \ + --no-title \ + --outputfile "$LOGFILE" \ + --command "ghci -ghci-script .ghci-core"