generated from coulomb/repo-seed
feat(WP-0013): IHF Phase 12 — Platform Memory and Continuous Learning
Closes the long-range feedback loop: outcome signals now enrich the full
traceability chain and feed back into routing, triage, and AI proposals.
Schema (T01):
- outcome_correlations (CHECK correlation_type)
- pattern_performance_records
- adaptive_threshold_configs
- institutional_knowledge_entries (GIN tsvector FTS)
- learning_insights (CHECK insight_type)
- ALTER TABLE decision_records + requirement_candidates: outcome_summary JSONB
- AFTER INSERT trigger trg_enrich_lineage on outcome_signals
- contracts/core/ updated (outcome-summary-columns-v1, append-only addendum)
Correlation engine (T02):
- Application/Helper/CorrelationEngine.hs: pure annotation→outcome SQL
- Web/Controller/OutcomeCorrelations.hs: ComputeCorrelationsAction + index
Pattern performance (T03):
- Web/Controller/PatternPerformance.hs: ComputePatternPerformanceAction
Adaptive thresholds (T04):
- Web/Controller/AdaptiveThresholds.hs: CalibrateThresholdsAction
- Application/Helper/FrictionScore.hs: applyAdaptiveWeights
Institutional knowledge (T05):
- DistilDecisionAction in DecisionRecords controller
- Web/Controller/InstitutionalKnowledge.hs: QueryKnowledgeBaseAction
Lineage enrichment (T06):
- Web/Controller/LineageEnrichment.hs: EnrichLineageAction (batch backfill)
- enrich_lineage_on_outcome_batch() PL/pgSQL helper in migration
Learning dashboard (T07):
- Web/Controller/LearningDashboard.hs: 5-panel autoRefresh view
- "Learning" nav link in FrontController
API v2 learning endpoints (T08):
- GET /api/v2/outcome-correlations, /pattern-performance, /knowledge-base/{id}
- OpenAPI schemas: OutcomeCorrelation, PatternPerformanceRecord, InstitutionalKnowledgeEntry
GAAF scorecard + docs (T09):
- Core 3.8→3.9, Functional 3.6→3.8, overall 3.61→3.68
- CLAUDE.md: IHF v0.2 complete, no active workplan
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
86
Web/Controller/AdaptiveThresholds.hs
Normal file
86
Web/Controller/AdaptiveThresholds.hs
Normal file
@@ -0,0 +1,86 @@
|
||||
module Web.Controller.AdaptiveThresholds where
|
||||
|
||||
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T04)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.AdaptiveThresholds.Index
|
||||
import IHP.ModelSupport (sqlQuery)
|
||||
import Database.PostgreSQL.Simple (Only(..))
|
||||
|
||||
instance Controller AdaptiveThresholdsController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action AdaptiveThresholdsAction = do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
configs <- query @AdaptiveThresholdConfig |> fetch
|
||||
insights <- query @LearningInsight
|
||||
|> filterWhere (#insightType, "threshold_calibration")
|
||||
|> orderByDesc #computedAt
|
||||
|> limit 10
|
||||
|> fetch
|
||||
render IndexView { hubs, configs, insights }
|
||||
|
||||
action CalibrateThresholdsAction { hubIdForThreshold } = do
|
||||
let hubId = hubIdForThreshold
|
||||
-- Step 1: find weak-predictor categories (score < 0.3)
|
||||
weakCats <- sqlQuery
|
||||
"SELECT annotation_category FROM outcome_correlations \
|
||||
\ WHERE hub_id = ? AND correlation_score < 0.3"
|
||||
[hubId]
|
||||
:: IO [Only Text]
|
||||
|
||||
-- Step 2: compute bottleneck threshold override = mean friction score
|
||||
-- for widgets with at least one negative outcome signal
|
||||
[Only mBottleneckOverride] <- sqlQuery
|
||||
"SELECT AVG(fs.score) \
|
||||
\ FROM friction_scores fs \
|
||||
\ JOIN widgets w ON w.id = fs.widget_id \
|
||||
\ WHERE w.hub_id = ? \
|
||||
\ AND EXISTS ( \
|
||||
\ SELECT 1 FROM outcome_signals os \
|
||||
\ JOIN deployment_records dep ON dep.id = os.deployment_id \
|
||||
\ JOIN decision_records dr ON dr.id = dep.decision_id \
|
||||
\ JOIN requirements r ON r.id = dr.requirement_id \
|
||||
\ JOIN requirement_candidates rc ON rc.id = r.candidate_id \
|
||||
\ WHERE rc.source_widget_id = w.id \
|
||||
\ AND os.signal_type NOT IN ('success','adoption','satisfaction') \
|
||||
\ )"
|
||||
[hubId]
|
||||
:: IO [Only (Maybe Double)]
|
||||
|
||||
now <- getCurrentTime
|
||||
let weakNote = "Weak predictor categories (score < 0.3): "
|
||||
<> intercalate ", " (map fromOnly weakCats)
|
||||
|
||||
-- Step 3: upsert AdaptiveThresholdConfig
|
||||
existing <- query @AdaptiveThresholdConfig
|
||||
|> filterWhere (#hubId, hubId)
|
||||
|> fetchOneOrNothing
|
||||
case existing of
|
||||
Just cfg ->
|
||||
cfg
|
||||
|> set #bottleneckThresholdOverride mBottleneckOverride
|
||||
|> set #calibrationDate now
|
||||
|> set #notes (Just weakNote)
|
||||
|> updateRecord
|
||||
Nothing ->
|
||||
newRecord @AdaptiveThresholdConfig
|
||||
|> set #hubId hubId
|
||||
|> set #weightOverrides (A.Object mempty)
|
||||
|> set #bottleneckThresholdOverride mBottleneckOverride
|
||||
|> set #calibrationDate now
|
||||
|> set #notes (Just weakNote)
|
||||
|> createRecord
|
||||
|
||||
-- Step 4: write LearningInsight
|
||||
newRecord @LearningInsight
|
||||
|> set #hubId hubId
|
||||
|> set #insightType "threshold_calibration"
|
||||
|> set #title "Adaptive threshold calibration completed"
|
||||
|> set #body ("Calibrated friction thresholds. " <> weakNote
|
||||
<> maybe "" (\b -> " Bottleneck override: " <> show b) mBottleneckOverride)
|
||||
|> set #evidenceLinks (A.toJSON ([] :: [A.Value]))
|
||||
|> createRecord
|
||||
|
||||
setSuccessMessage "Threshold calibration complete"
|
||||
redirectTo AdaptiveThresholdsAction
|
||||
106
Web/Controller/Api/V2/Learning.hs
Normal file
106
Web/Controller/Api/V2/Learning.hs
Normal file
@@ -0,0 +1,106 @@
|
||||
module Web.Controller.Api.V2.Learning where
|
||||
|
||||
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T08)
|
||||
|
||||
import Web.Types
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
import Data.Aeson (object, (.=))
|
||||
import Web.Controller.Api.V2.Auth (requireApiConsumer, paginatedResponse, getPageParams)
|
||||
import IHP.ModelSupport (sqlQuery)
|
||||
|
||||
instance Controller ApiV2LearningController where
|
||||
|
||||
action ApiV2IndexOutcomeCorrelationsAction = do
|
||||
_consumer <- requireApiConsumer
|
||||
mHubId <- paramOrNothing @(Id Hub) "hub_id"
|
||||
mCat <- paramOrNothing @Text "category"
|
||||
(page, perPage) <- getPageParams
|
||||
let off = (page - 1) * perPage
|
||||
baseQuery <- pure $ query @OutcomeCorrelation
|
||||
filtered <- pure $ case mHubId of
|
||||
Nothing -> baseQuery
|
||||
Just hid -> baseQuery |> filterWhere (#hubId, hid)
|
||||
filteredCat <- pure $ case mCat of
|
||||
Nothing -> filtered
|
||||
Just cat -> filtered |> filterWhere (#annotationCategory, cat)
|
||||
total <- filteredCat |> fetchCount
|
||||
rows <- filteredCat |> orderByDesc #correlationScore |> limit perPage |> offset off |> fetch
|
||||
renderJson $ paginatedResponse (map correlationToJson rows) page perPage total
|
||||
|
||||
action ApiV2IndexPatternPerformanceAction = do
|
||||
_consumer <- requireApiConsumer
|
||||
(page, perPage) <- getPageParams
|
||||
let off = (page - 1) * perPage
|
||||
total <- query @PatternPerformanceRecord |> fetchCount
|
||||
rows <- query @PatternPerformanceRecord
|
||||
|> orderByAsc #outcomeRank
|
||||
|> limit perPage
|
||||
|> offset off
|
||||
|> fetch
|
||||
renderJson $ paginatedResponse (map patternPerfToJson rows) page perPage total
|
||||
|
||||
action ApiV2IndexKnowledgeBaseAction = do
|
||||
_consumer <- requireApiConsumer
|
||||
mQ <- paramOrNothing @Text "q"
|
||||
(page, perPage) <- getPageParams
|
||||
let off = (page - 1) * perPage
|
||||
rows <- case mQ of
|
||||
Nothing -> query @InstitutionalKnowledgeEntry
|
||||
|> orderByDesc #createdAt
|
||||
|> limit perPage
|
||||
|> offset off
|
||||
|> fetch
|
||||
Just q -> sqlQuery
|
||||
"SELECT * FROM institutional_knowledge_entries \
|
||||
\ WHERE summary_tsv @@ plainto_tsquery('english', ?) \
|
||||
\ ORDER BY ts_rank(summary_tsv, plainto_tsquery('english', ?)) DESC \
|
||||
\ LIMIT ? OFFSET ?"
|
||||
(q, q, perPage, off)
|
||||
renderJson (map knowledgeToJson rows)
|
||||
|
||||
action ApiV2ShowKnowledgeBaseAction { knowledgeEntryId } = do
|
||||
_consumer <- requireApiConsumer
|
||||
entry <- fetch knowledgeEntryId
|
||||
renderJson (knowledgeToJson entry)
|
||||
|
||||
correlationToJson :: OutcomeCorrelation -> Value
|
||||
correlationToJson c = object
|
||||
[ "id" .= c.id
|
||||
, "hubId" .= c.hubId
|
||||
, "annotationCategory" .= c.annotationCategory
|
||||
, "correlationType" .= c.correlationType
|
||||
, "correlationScore" .= c.correlationScore
|
||||
, "sampleCount" .= c.sampleCount
|
||||
, "computedAt" .= c.computedAt
|
||||
]
|
||||
|
||||
patternPerfToJson :: PatternPerformanceRecord -> Value
|
||||
patternPerfToJson r =
|
||||
let positiveRate = if r.totalOutcomeCount > 0
|
||||
then fromIntegral r.positiveOutcomeCount / fromIntegral r.totalOutcomeCount :: Double
|
||||
else 0.0
|
||||
in object
|
||||
[ "id" .= r.id
|
||||
, "widgetPatternId" .= r.widgetPatternId
|
||||
, "hubId" .= r.hubId
|
||||
, "adoptionCount" .= r.adoptionCount
|
||||
, "positiveOutcomeCount" .= r.positiveOutcomeCount
|
||||
, "totalOutcomeCount" .= r.totalOutcomeCount
|
||||
, "positiveOutcomeRate" .= positiveRate
|
||||
, "meanOutcomeValue" .= r.meanOutcomeValue
|
||||
, "outcomeRank" .= r.outcomeRank
|
||||
, "calibratedAt" .= r.calibratedAt
|
||||
]
|
||||
|
||||
knowledgeToJson :: InstitutionalKnowledgeEntry -> Value
|
||||
knowledgeToJson e = object
|
||||
[ "id" .= e.id
|
||||
, "hubId" .= e.hubId
|
||||
, "decisionRecordId" .= e.decisionRecordId
|
||||
, "summary" .= e.summary
|
||||
, "tags" .= e.tags
|
||||
, "createdAt" .= e.createdAt
|
||||
, "updatedAt" .= e.updatedAt
|
||||
]
|
||||
@@ -90,6 +90,9 @@ buildOpenApiSpec = do
|
||||
, "DecisionRecord" .= drSchema
|
||||
, "DeploymentRecord" .= depSchema
|
||||
, "OutcomeSignal" .= sigSchema
|
||||
, "OutcomeCorrelation" .= outcomeCorrelationSchema
|
||||
, "PatternPerformanceRecord" .= patternPerformanceSchema
|
||||
, "InstitutionalKnowledgeEntry" .= institutionalKnowledgeSchema
|
||||
]
|
||||
, "securitySchemes" .= object
|
||||
[ "BearerAuth" .= object
|
||||
@@ -367,6 +370,51 @@ sigSchema = object
|
||||
]
|
||||
]
|
||||
|
||||
outcomeCorrelationSchema :: Value
|
||||
outcomeCorrelationSchema = object
|
||||
[ "type" .= ("object" :: Text)
|
||||
, "properties" .= object
|
||||
[ "id" .= uuidProp
|
||||
, "hubId" .= uuidProp
|
||||
, "annotationCategory" .= strProp
|
||||
, "correlationType" .= strProp
|
||||
, "correlationScore" .= object ["type" .= ("number" :: Text)]
|
||||
, "sampleCount" .= object ["type" .= ("integer" :: Text)]
|
||||
, "computedAt" .= dtProp
|
||||
]
|
||||
]
|
||||
|
||||
patternPerformanceSchema :: Value
|
||||
patternPerformanceSchema = object
|
||||
[ "type" .= ("object" :: Text)
|
||||
, "properties" .= object
|
||||
[ "id" .= uuidProp
|
||||
, "widgetPatternId" .= uuidProp
|
||||
, "hubId" .= uuidProp
|
||||
, "adoptionCount" .= object ["type" .= ("integer" :: Text)]
|
||||
, "positiveOutcomeCount" .= object ["type" .= ("integer" :: Text)]
|
||||
, "totalOutcomeCount" .= object ["type" .= ("integer" :: Text)]
|
||||
, "positiveOutcomeRate" .= object ["type" .= ("number" :: Text)]
|
||||
, "meanOutcomeValue" .= object ["type" .= ("number" :: Text)]
|
||||
, "outcomeRank" .= object ["type" .= ("integer" :: Text)]
|
||||
, "calibratedAt" .= dtProp
|
||||
]
|
||||
]
|
||||
|
||||
institutionalKnowledgeSchema :: Value
|
||||
institutionalKnowledgeSchema = object
|
||||
[ "type" .= ("object" :: Text)
|
||||
, "properties" .= object
|
||||
[ "id" .= uuidProp
|
||||
, "hubId" .= uuidProp
|
||||
, "decisionRecordId" .= uuidProp
|
||||
, "summary" .= strProp
|
||||
, "tags" .= object ["type" .= ("array" :: Text)]
|
||||
, "createdAt" .= dtProp
|
||||
, "updatedAt" .= dtProp
|
||||
]
|
||||
]
|
||||
|
||||
uuidProp :: Value
|
||||
uuidProp = object ["type" .= ("string" :: Text), "format" .= ("uuid" :: Text)]
|
||||
|
||||
|
||||
@@ -11,6 +11,8 @@ import IHP.ControllerPrelude
|
||||
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage)
|
||||
import Application.Helper.ModelRouter (resolveAgent)
|
||||
import Data.List (intercalate)
|
||||
import IHP.ModelSupport (sqlQuery)
|
||||
import qualified Data.Aeson as A
|
||||
|
||||
validOutcomes :: [Text]
|
||||
validOutcomes = ["accepted", "rejected", "deferred", "split", "merged", "reframed"]
|
||||
@@ -242,3 +244,60 @@ instance Controller DecisionRecordsController where
|
||||
|> createRecord
|
||||
setSuccessMessage "Implementation proposal created"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
|
||||
-- T05 / Phase 12: Distil decision into institutional knowledge entry
|
||||
action DistilDecisionAction { decisionRecordId } = do
|
||||
record <- fetch decisionRecordId
|
||||
outcomes <- sqlQuery
|
||||
"SELECT os.signal_type, os.value FROM outcome_signals os \
|
||||
\ JOIN deployment_records dep ON dep.id = os.deployment_id \
|
||||
\ WHERE dep.decision_id = ?"
|
||||
[decisionRecordId]
|
||||
:: IO [(Text, Maybe Double)]
|
||||
let signalText = intercalate ", " $
|
||||
map (\(st, mv) -> st <> maybe "" (\v -> "=" <> show v) mv) outcomes
|
||||
prompt = "Distil this decision into a 2-3 sentence institutional knowledge entry. "
|
||||
<> "Include the outcome data.\n\nDecision: " <> record.title
|
||||
<> "\nRationale: " <> record.rationale
|
||||
<> "\nOutcome: " <> record.outcome
|
||||
<> "\nSignals: " <> signalText
|
||||
-- Resolve hub from requirement chain
|
||||
mHubId <- case record.requirementId of
|
||||
Nothing -> pure Nothing
|
||||
Just rid -> do
|
||||
mReq <- fetchOneOrNothing rid
|
||||
pure $ case mReq >>= (.sourceWidgetId) of
|
||||
Nothing -> Nothing
|
||||
Just _ -> Nothing -- hub resolution via widget lookup below
|
||||
mHubIdResolved <- case record.requirementId of
|
||||
Nothing -> pure Nothing
|
||||
Just rid -> do
|
||||
mReq <- fetchOneOrNothing rid
|
||||
case mReq >>= (.sourceWidgetId) of
|
||||
Nothing -> pure Nothing
|
||||
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
|
||||
case mHubIdResolved of
|
||||
Nothing -> do
|
||||
setErrorMessage "Cannot resolve hub — ensure decision has a linked requirement with a source widget"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
Just hubId -> do
|
||||
mAgent <- resolveAgent hubId "synthesis"
|
||||
case mAgent of
|
||||
Nothing -> do
|
||||
setErrorMessage "No routing policy for 'synthesis' task type"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
Just agent -> do
|
||||
result <- liftIO $ callAgent agent prompt
|
||||
case result of
|
||||
Left err -> do
|
||||
setErrorMessage ("Distillation failed: " <> bridgeErrorMessage err)
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
Right resp -> do
|
||||
newRecord @InstitutionalKnowledgeEntry
|
||||
|> set #hubId hubId
|
||||
|> set #decisionRecordId (Just decisionRecordId)
|
||||
|> set #summary resp.content
|
||||
|> set #tags (A.toJSON ["decision" :: Text])
|
||||
|> createRecord
|
||||
setSuccessMessage "Knowledge entry created"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
|
||||
49
Web/Controller/InstitutionalKnowledge.hs
Normal file
49
Web/Controller/InstitutionalKnowledge.hs
Normal file
@@ -0,0 +1,49 @@
|
||||
module Web.Controller.InstitutionalKnowledge where
|
||||
|
||||
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T05)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.InstitutionalKnowledge.Index
|
||||
import Web.View.InstitutionalKnowledge.Show
|
||||
import IHP.ModelSupport (sqlQuery)
|
||||
|
||||
instance Controller InstitutionalKnowledgeController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action InstitutionalKnowledgeAction = do
|
||||
entries <- query @InstitutionalKnowledgeEntry
|
||||
|> orderByDesc #createdAt
|
||||
|> limit 50
|
||||
|> fetch
|
||||
hubs <- query @Hub |> fetch
|
||||
render IndexView { entries, hubs, mQuery = Nothing }
|
||||
|
||||
action ShowInstitutionalKnowledgeAction { knowledgeEntryId } = do
|
||||
entry <- fetch knowledgeEntryId
|
||||
hub <- fetch entry.hubId
|
||||
mDecision <- case entry.decisionRecordId of
|
||||
Nothing -> pure Nothing
|
||||
Just did -> fetchOneOrNothing did
|
||||
render ShowView { entry, hub, mDecision }
|
||||
|
||||
action QueryKnowledgeBaseAction = do
|
||||
q <- param @Text "q"
|
||||
mHubStr <- paramOrNothing @Text "hubId"
|
||||
hubs <- query @Hub |> fetch
|
||||
entries <- case mHubStr of
|
||||
Nothing ->
|
||||
sqlQuery
|
||||
"SELECT * FROM institutional_knowledge_entries \
|
||||
\ WHERE summary_tsv @@ plainto_tsquery('english', ?) \
|
||||
\ ORDER BY ts_rank(summary_tsv, plainto_tsquery('english', ?)) DESC \
|
||||
\ LIMIT 20"
|
||||
(q, q)
|
||||
Just hid ->
|
||||
sqlQuery
|
||||
"SELECT * FROM institutional_knowledge_entries \
|
||||
\ WHERE hub_id = ? \
|
||||
\ AND summary_tsv @@ plainto_tsquery('english', ?) \
|
||||
\ ORDER BY ts_rank(summary_tsv, plainto_tsquery('english', ?)) DESC \
|
||||
\ LIMIT 20"
|
||||
(hid, q, q)
|
||||
render IndexView { entries, hubs, mQuery = Just q }
|
||||
32
Web/Controller/LearningDashboard.hs
Normal file
32
Web/Controller/LearningDashboard.hs
Normal file
@@ -0,0 +1,32 @@
|
||||
module Web.Controller.LearningDashboard where
|
||||
|
||||
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T07)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.LearningDashboard.Show
|
||||
|
||||
instance Controller LearningDashboardController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action LearningDashboardAction = do
|
||||
autoRefresh
|
||||
topCorrelations <- query @OutcomeCorrelation
|
||||
|> orderByDesc #correlationScore
|
||||
|> limit 10
|
||||
|> fetch
|
||||
patternRankings <- query @PatternPerformanceRecord
|
||||
|> orderByAsc #outcomeRank
|
||||
|> limit 10
|
||||
|> fetch
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
configs <- query @AdaptiveThresholdConfig |> fetch
|
||||
let thresholdStatus = map (\h -> (h, find (\c -> c.hubId == h.id) configs)) hubs
|
||||
recentInsights <- query @LearningInsight
|
||||
|> orderByDesc #computedAt
|
||||
|> limit 10
|
||||
|> fetch
|
||||
knowledgeHighlights <- query @InstitutionalKnowledgeEntry
|
||||
|> orderByDesc #createdAt
|
||||
|> limit 5
|
||||
|> fetch
|
||||
render ShowView { topCorrelations, patternRankings, thresholdStatus, recentInsights, knowledgeHighlights }
|
||||
42
Web/Controller/LineageEnrichment.hs
Normal file
42
Web/Controller/LineageEnrichment.hs
Normal file
@@ -0,0 +1,42 @@
|
||||
module Web.Controller.LineageEnrichment where
|
||||
|
||||
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T06)
|
||||
-- The AFTER INSERT trigger trg_enrich_lineage handles real-time enrichment.
|
||||
-- This controller provides on-demand batch backfill for existing records.
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.LineageEnrichment.Index
|
||||
import IHP.ModelSupport (sqlQuery)
|
||||
import Database.PostgreSQL.Simple (Only(..))
|
||||
|
||||
instance Controller LineageEnrichmentController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action LineageEnrichmentAction = do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
-- Count unenriched decisions per hub
|
||||
counts <- sqlQuery
|
||||
"SELECT dr.hub_id, COUNT(*) FILTER (WHERE dr.outcome_summary IS NULL)::int AS unenriched \
|
||||
\ FROM decision_records dr \
|
||||
\ GROUP BY dr.hub_id"
|
||||
()
|
||||
:: IO [(Id Hub, Int)]
|
||||
render IndexView { hubs, counts }
|
||||
|
||||
action EnrichLineageAction { hubIdForLineage } = do
|
||||
let hubId = hubIdForLineage
|
||||
-- Batch-call the trigger logic via a PL/pgSQL function for all
|
||||
-- outcome_signals in this hub that haven't yet enriched their chain.
|
||||
[Only enriched] <- sqlQuery
|
||||
"SELECT COUNT(*) FROM ( \
|
||||
\ SELECT enrich_lineage_on_outcome_batch(os.id) \
|
||||
\ FROM outcome_signals os \
|
||||
\ JOIN deployment_records dep ON dep.id = os.deployment_id \
|
||||
\ JOIN decision_records dr ON dr.id = dep.decision_id \
|
||||
\ WHERE dr.hub_id = ? \
|
||||
\ AND dr.outcome_summary IS NULL \
|
||||
\ ) sub"
|
||||
[hubId]
|
||||
:: IO [Only Int]
|
||||
setSuccessMessage ("Lineage enriched for " <> show enriched <> " signals")
|
||||
redirectTo LineageEnrichmentAction
|
||||
58
Web/Controller/OutcomeCorrelations.hs
Normal file
58
Web/Controller/OutcomeCorrelations.hs
Normal file
@@ -0,0 +1,58 @@
|
||||
module Web.Controller.OutcomeCorrelations where
|
||||
|
||||
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T02)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.OutcomeCorrelations.Index
|
||||
import Application.Helper.CorrelationEngine (computeAnnotationCorrelations)
|
||||
import Data.Aeson ((.=), object)
|
||||
|
||||
instance Controller OutcomeCorrelationsController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action OutcomeCorrelationsAction = do
|
||||
mHubFilter <- paramOrNothing @(Id Hub) "hubId"
|
||||
correlations <- case mHubFilter of
|
||||
Nothing -> query @OutcomeCorrelation
|
||||
|> orderByDesc #correlationScore
|
||||
|> fetch
|
||||
Just hid -> query @OutcomeCorrelation
|
||||
|> filterWhere (#hubId, hid)
|
||||
|> orderByDesc #correlationScore
|
||||
|> fetch
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
render IndexView { correlations, hubs, mHubFilter }
|
||||
|
||||
action ComputeCorrelationsAction { hubId } = do
|
||||
rows <- liftIO $ computeAnnotationCorrelations hubId
|
||||
now <- getCurrentTime
|
||||
-- Upsert: delete existing rows for this hub then insert fresh
|
||||
deleteWhere @OutcomeCorrelation (#hubId, hubId)
|
||||
forM_ rows \(category, score, sampleCount) ->
|
||||
newRecord @OutcomeCorrelation
|
||||
|> set #hubId hubId
|
||||
|> set #annotationCategory category
|
||||
|> set #correlationType "annotation_predictor"
|
||||
|> set #correlationScore score
|
||||
|> set #sampleCount sampleCount
|
||||
|> set #computedAt now
|
||||
|> createRecord
|
||||
|
||||
-- Generate LearningInsight for top-scoring category
|
||||
case rows of
|
||||
((topCat, topScore, _) : _) | topScore >= 0.4 ->
|
||||
newRecord @LearningInsight
|
||||
|> set #hubId hubId
|
||||
|> set #insightType "annotation_predictor"
|
||||
|> set #title ("Strong predictor: annotation category '" <> topCat <> "'")
|
||||
|> set #body ("Annotation category '" <> topCat <> "' shows a correlation score of "
|
||||
<> show topScore <> " with positive outcomes. Consider weighting this category "
|
||||
<> "higher in triage and routing decisions.")
|
||||
|> set #evidenceLinks (A.toJSON
|
||||
[object ["type" .= ("outcome_correlation" :: Text), "category" .= topCat]])
|
||||
|> createRecord
|
||||
>> pure ()
|
||||
_ -> pure ()
|
||||
|
||||
setSuccessMessage ("Correlations computed: " <> show (length rows) <> " categories")
|
||||
redirectTo OutcomeCorrelationsAction
|
||||
66
Web/Controller/PatternPerformance.hs
Normal file
66
Web/Controller/PatternPerformance.hs
Normal file
@@ -0,0 +1,66 @@
|
||||
module Web.Controller.PatternPerformance where
|
||||
|
||||
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T03)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.PatternPerformance.Index
|
||||
import IHP.ModelSupport (sqlQuery)
|
||||
|
||||
instance Controller PatternPerformanceController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action PatternPerformanceAction = do
|
||||
records <- query @PatternPerformanceRecord
|
||||
|> orderByAsc #outcomeRank
|
||||
|> fetch
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
render IndexView { records, hubs }
|
||||
|
||||
action ComputePatternPerformanceAction { hubIdForPerformance } = do
|
||||
let hubId = hubIdForPerformance
|
||||
rows <- sqlQuery
|
||||
"SELECT \
|
||||
\ wp.id AS pattern_id, \
|
||||
\ COUNT(DISTINCT pa.id)::int AS adoption_count, \
|
||||
\ COUNT(os.id)::int AS total_outcome_count, \
|
||||
\ COUNT(os.id) FILTER ( \
|
||||
\ WHERE os.signal_type IN ('success','adoption','satisfaction') \
|
||||
\ )::int AS positive_outcome_count, \
|
||||
\ AVG(os.value) AS mean_outcome_value \
|
||||
\ FROM widget_patterns wp \
|
||||
\ JOIN pattern_adoptions pa ON pa.widget_pattern_id = wp.id \
|
||||
\ JOIN widgets w ON w.hub_id = pa.adopting_hub_id \
|
||||
\ AND w.widget_type = wp.widget_type \
|
||||
\ JOIN deployment_records dep ON dep.id IN ( \
|
||||
\ SELECT dep2.id FROM deployment_records dep2 \
|
||||
\ JOIN decision_records dr2 ON dr2.id = dep2.decision_id \
|
||||
\ JOIN requirements r2 ON r2.id = dr2.requirement_id \
|
||||
\ JOIN requirement_candidates rc2 ON rc2.id = r2.candidate_id \
|
||||
\ WHERE rc2.source_widget_id = w.id \
|
||||
\ ) \
|
||||
\ JOIN outcome_signals os ON os.deployment_id = dep.id \
|
||||
\ WHERE pa.adopting_hub_id = ? \
|
||||
\ GROUP BY wp.id"
|
||||
[hubId]
|
||||
:: IO [(Id WidgetPattern, Int, Int, Int, Maybe Double)]
|
||||
|
||||
now <- getCurrentTime
|
||||
-- Delete existing records for this hub then insert fresh
|
||||
deleteWhere @PatternPerformanceRecord (#hubId, hubId)
|
||||
-- Insert with rank computation
|
||||
let sorted = sortBy (\(_, _, _, pos1, _) (_, _, _, pos2, _) -> compare pos2 pos1) rows
|
||||
ranked = zip [1..] sorted
|
||||
forM_ ranked \(rank, (patId, adoptions, total, positive, meanVal)) ->
|
||||
newRecord @PatternPerformanceRecord
|
||||
|> set #widgetPatternId patId
|
||||
|> set #hubId hubId
|
||||
|> set #adoptionCount adoptions
|
||||
|> set #positiveOutcomeCount positive
|
||||
|> set #totalOutcomeCount total
|
||||
|> set #meanOutcomeValue meanVal
|
||||
|> set #outcomeRank (Just rank)
|
||||
|> set #calibratedAt now
|
||||
|> createRecord
|
||||
|
||||
setSuccessMessage ("Pattern performance computed: " <> show (length rows) <> " patterns")
|
||||
redirectTo PatternPerformanceAction
|
||||
Reference in New Issue
Block a user