From e3e8260b9ee7eb9ffca9fa13317bf7981063acc0 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 16 Dec 2025 17:19:31 +0000 Subject: [PATCH 001/149] Hugr: move parent pointer outside of node --- brat/Brat/Compile/Hugr.hs | 171 +++++++-------- brat/Data/Hugr.hs | 436 ++++++++++++++++++-------------------- 2 files changed, 290 insertions(+), 317 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 6c169733..9b0d4f9e 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -55,7 +55,7 @@ data CompilationState = CompilationState { bratGraph :: Graph -- the input BRAT Graph; should not be written , capSets :: CaptureSets -- environments captured by Box nodes in previous , nameSupply :: Namespace - , nodes :: M.Map NodeId (HugrOp NodeId) -- this node's id => HugrOp containing parent id + , nodes :: M.Map NodeId (NodeId, HugrOp) -- this node's id => HugrOp containing parent id , edges :: [(PortId NodeId, PortId NodeId)] , compiled :: M.Map Name NodeId -- Mapping from Brat nodes to Hugr nodes -- When lambda lifting, captured variables become extra function inputs. @@ -105,10 +105,10 @@ addEdge e = do let es = edges st put (st { edges = e:es }) -addNode :: String -> HugrOp NodeId -> Compile NodeId -addNode name op = do +addNode :: String -> (NodeId, HugrOp) -> Compile NodeId +addNode name (parent, op) = do id <- freshNode name - addOp (addMetadata [("id", show id)] op) id + addOp (parent, addMetadata [("id", show id)] op) id pure id type Compile = State CompilationState @@ -181,7 +181,7 @@ compileGraphTypes = traverse ((<&> compileType) . runCheckingInCompile . eval S0 compilePorts :: [(a, Val Z)] -> Compile [HugrType] compilePorts = compileGraphTypes . map snd -addOp :: HugrOp NodeId -> NodeId -> Compile () +addOp :: (NodeId, HugrOp) -> NodeId -> Compile () addOp op name | track ("addOp " ++ show op ++ show name) False = undefined addOp op name = do st <- get @@ -196,47 +196,51 @@ registerCompiled from to = do compileConst :: NodeId -> SimpleTerm -> HugrType -> Compile NodeId compileConst parent tm ty = do - constId <- addNode "Const" (OpConst (ConstOp parent (valFromSimple tm))) + constId <- addNode "Const" (parent, OpConst (ConstOp (valFromSimple tm))) loadId <- case ty of HTFunc poly@(PolyFuncType [] _) -> - addNode "LoadFunction" (OpLoadFunction (LoadFunctionOp parent poly [] (FunctionType [] [HTFunc poly] []))) + addNode "LoadFunction" (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) HTFunc (PolyFuncType _ _) -> error "Trying to compile function with type args" - _ -> addNode "LoadConst" (OpLoadConstant (LoadConstantOp parent ty)) + _ -> addNode "LoadConst" (parent, OpLoadConstant (LoadConstantOp ty)) addEdge (Port constId 0, Port loadId 0) pure loadId compileArithNode :: NodeId -> ArithOp -> Val Z -> Compile NodeId -compileArithNode parent op TNat = addNode (show op ++ "_Nat") $ OpCustom $ case op of - Add -> binaryIntOp parent "iadd" - Sub -> binaryIntOp parent "isub" - Mul-> binaryIntOp parent "imul" - Div -> intOp parent "idiv_u" [hugrInt, hugrInt] [hugrInt] [TANat intWidth, TANat intWidth] +compileArithNode parent op TNat = addNode (show op ++ "_Nat") (parent, OpCustom $ case op of + Add -> binaryIntOp "iadd" + Sub -> binaryIntOp "isub" + Mul-> binaryIntOp "imul" + Div -> intOp "idiv_u" [hugrInt, hugrInt] [hugrInt] [TANat intWidth, TANat intWidth] Pow -> error "TODO: Pow" -- Not defined in extension -compileArithNode parent op TInt = addNode (show op ++ "_Int") $ OpCustom $ case op of - Add -> binaryIntOp parent "iadd" - Sub -> binaryIntOp parent "isub" - Mul-> binaryIntOp parent "imul" - Div -> intOp parent "idiv_u" [hugrInt, hugrInt] [hugrInt] [TANat intWidth, TANat intWidth] + ) +compileArithNode parent op TInt = addNode (show op ++ "_Int") (parent, OpCustom $ case op of + Add -> binaryIntOp "iadd" + Sub -> binaryIntOp "isub" + Mul-> binaryIntOp "imul" + Div -> intOp "idiv_u" [hugrInt, hugrInt] [hugrInt] [TANat intWidth, TANat intWidth] Pow -> error "TODO: Pow" -- Not defined in extension -compileArithNode parent op TFloat = addNode (show op ++ "_Float") $ OpCustom $ case op of - Add -> binaryFloatOp parent "fadd" - Sub -> binaryFloatOp parent "fsub" - Mul-> binaryFloatOp parent "fmul" - Div-> binaryFloatOp parent "fdiv" + ) +compileArithNode parent op TFloat = addNode (show op ++ "_Float") (parent, OpCustom $ case op of + Add -> binaryFloatOp "fadd" + Sub -> binaryFloatOp "fsub" + Mul-> binaryFloatOp "fmul" + Div-> binaryFloatOp "fdiv" Pow -> error "TODO: Pow" -- Not defined in extension + ) compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty -renameAndSortHugr :: M.Map NodeId (HugrOp NodeId) -> [(PortId NodeId, PortId NodeId)] -> Hugr Int -renameAndSortHugr nodes edges = indexMetadata $ fmap update (Hugr (fst <$> sorted_nodes) (edges ++ orderEdges)) where +renameAndSortHugr :: M.Map NodeId (NodeId, HugrOp) -> [(PortId NodeId, PortId NodeId)] -> Hugr Int +renameAndSortHugr nodes edges = indexMetadata $ fmap update (Hugr (swap . fst <$> sorted_nodes) (edges ++ orderEdges)) where indexMetadata :: Hugr Int -> Hugr Int - indexMetadata (Hugr ops edges) = Hugr [addMetadata [("index", show ix)] op | (ix, op) <- zip [0..] ops] edges + indexMetadata (Hugr ops edges) = Hugr [(p, addMetadata [("index", show ix)] op) | (ix, (p, op)) <- zip [0..] ops] edges - - sorted_nodes = let ([root], rest) = partition (\(n, nid) -> nid == getParent n) (swap <$> M.assocs nodes) in - root : sort rest + sorted_nodes :: [((HugrOp, NodeId), NodeId)] -- (op, parent), name + sorted_nodes = let ([root], rest) = partition (\((_op, parent), nid) -> nid == parent) + [((op, parent), nid) | (nid, (parent, op)) <- M.assocs nodes] + in root : (sort rest) -- sort rest by op names2Pos = M.fromList $ zip (snd <$> sorted_nodes) ([0..] :: [Int]) - parentOf n = getParent (nodes M.! n) + parentOf n = let (parent, _) = (nodes M.! n) in parent update :: NodeId -> Int update name = case M.lookup name names2Pos of @@ -253,10 +257,10 @@ renameAndSortHugr nodes edges = indexMetadata $ fmap update (Hugr (fst <$> sorte requiresOrderEdge (nodes M.! n2) ] in [(Port src orderEdgeOffset, Port tgt orderEdgeOffset) | (src, tgt) <- walkUp <$> interEdges] - requiresOrderEdge :: HugrOp NodeId -> Bool - requiresOrderEdge (OpMod _) = False - requiresOrderEdge (OpDefn _) = False - requiresOrderEdge (OpConst _) = False + requiresOrderEdge :: (NodeId, HugrOp) -> Bool + requiresOrderEdge (_, OpMod _) = False + requiresOrderEdge (_, OpDefn _) = False + requiresOrderEdge (_, OpConst _) = False requiresOrderEdge _ = True -- Walk up the hierarchy from the tgt until we hit a node at the same level as src @@ -298,12 +302,12 @@ compileClauses parent ins ((matchData, rhs) :| clauses) = do Just clauses -> compileClauses parent ins clauses -- If there are no more clauses left to test, then the Hugr panics Nothing -> let sig = FunctionType (snd <$> ins) outTys ["BRAT"] in - addNodeWithInputs "Panic" (OpCustom (CustomOp parent "BRAT" "panic" sig [])) ins outTys + addNodeWithInputs "Panic" (parent, OpCustom (CustomOp "BRAT" "panic" sig [])) ins outTys didMatch :: [HugrType] -> NodeId -> [TypedPort] -> Compile [TypedPort] didMatch outTys parent ins = gets bratGraph >>= \(ns,_) -> case ns M.! rhs of BratNode (Box src tgt) _ _ -> do - dfgId <- addNode "DidMatch_DFG" (OpDFG (DFG parent (FunctionType (snd <$> ins) outTys bratExts) [])) + dfgId <- addNode "DidMatch_DFG" (parent, OpDFG (DFG (FunctionType (snd <$> ins) outTys bratExts) [])) compileBox (src, tgt) dfgId for_ (zip (fst <$> ins) (Port dfgId <$> [0..])) addEdge pure $ zip (Port dfgId <$> [0..]) outTys @@ -339,13 +343,13 @@ compileWithInputs parent name = gets compiled >>= (\case let (funcDef, extra_call) = decls M.! name nod <- if extra_call then addNode ("direct_call(" ++ show funcDef ++ ")") - (OpCall (CallOp parent (FunctionType [] hTys bratExts))) + (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) -- We are loading idNode as a value (not an Eval'd thing), and it is a FuncDef directly -- corresponding to a Brat TLD (not that produces said TLD when eval'd) else case hTys of [HTFunc poly@(PolyFuncType [] _)] -> addNode ("load_thunk(" ++ show funcDef ++ ")") - (OpLoadFunction (LoadFunctionOp parent poly [] (FunctionType [] [HTFunc poly] []))) + (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) [HTFunc (PolyFuncType args _)] -> error $ unwords ["Unexpected type args to" ,show funcDef ++ ":" ,show args @@ -385,7 +389,7 @@ compileWithInputs parent name = gets compiled >>= (\case (ns, _) <- gets bratGraph case M.lookup outNode ns of Just (BratNode (Prim (ext,op)) _ [(_, VFun Kerny _)]) -> do - addNode (show suffix) (OpCustom (CustomOp parent ext op sig [])) + addNode (show suffix) (parent, OpCustom (CustomOp ext op sig [])) x -> error $ "Expected a Prim kernel node but got " ++ show x -- All other evaled things are turned into holes to be substituted later Nothing -> do @@ -394,7 +398,7 @@ compileWithInputs parent name = gets compiled >>= (\case let h = holes st put (st { holes = h :< name}) pure (length h) - addNode ("hole " ++ show hole) (OpCustom (holeOp parent hole sig)) + addNode ("hole " ++ show hole) (parent, OpCustom (holeOp hole sig)) -- A reference to a primitive op which exists in hugr. -- This should only have one outgoing wire which leads to an `Id` node for -- the brat representation of the function, and that wire should have a @@ -407,9 +411,9 @@ compileWithInputs parent name = gets compiled >>= (\case boxSig@(inputTys, outputTys) <- compileSig Braty cty let boxFunTy = FunctionType inputTys outputTys bratExts ((Port loadConst _, _ty), ()) <- compileConstDfg parent n boxSig $ \dfgId -> do - ins <- addNodeWithInputs ("Inputs" ++ n) (OpIn (InputNode dfgId inputTys [("source", "Prim")])) [] inputTys - outs <- addNodeWithInputs n (OpCustom (CustomOp dfgId ext op boxFunTy [])) ins outputTys - addNodeWithInputs ("Outputs" ++ n) (OpOut (OutputNode dfgId outputTys [("source", "Prim")])) outs [] + ins <- addNodeWithInputs ("Inputs" ++ n) (dfgId, OpIn (InputNode inputTys [("source", "Prim")])) [] inputTys + outs <- addNodeWithInputs n (dfgId, OpCustom (CustomOp ext op boxFunTy [])) ins outputTys + addNodeWithInputs ("Outputs" ++ n) (dfgId, OpOut (OutputNode outputTys [("source", "Prim")])) outs [] pure () pure $ default_edges loadConst @@ -423,13 +427,13 @@ compileWithInputs parent name = gets compiled >>= (\case -- Callee is a Prim node, insert Hugr Op; first look up outNode in the BRAT graph to get the Prim data Just suffix -> default_edges <$> case M.lookup outNode ns of Just (BratNode (Prim (ext,op)) _ _) -> do - addNode (show suffix) (OpCustom (CustomOp parent ext op (FunctionType ins outs [ext]) [])) + addNode (show suffix) (parent, OpCustom (CustomOp ext op (FunctionType ins outs [ext]) [])) x -> error $ "Expected a Prim node but got " ++ show x Nothing -> case hasPrefix ["checking", "globals"] outNode of -- Callee is a user-defined global def that, since it does not require an "extra" call, can be turned from IndirectCall to direct. Just _ | (funcDef, False) <- fromJust (M.lookup outNode decls) -> do callerId <- addNode ("direct_call(" ++ show funcDef ++ ")") - (OpCall (CallOp parent (FunctionType ins outs bratExts))) + (parent, OpCall (CallOp (FunctionType ins outs bratExts))) -- Add the static edge from the FuncDefn node to the port *after* -- all of the dynamic arguments to the Call node. -- This is because in hugr, static edges (like the graph arg to a @@ -441,7 +445,7 @@ compileWithInputs parent name = gets compiled >>= (\case _ -> compileWithInputs parent outNode >>= \case Just calleeId -> do callerId <- addNode ("indirect_call(" ++ show calleeId ++ ")") - (OpCallIndirect (CallIndirectOp parent (FunctionType ins outs bratExts {-[]-}))) + (parent, OpCallIndirect (CallIndirectOp (FunctionType ins outs bratExts {-[]-}))) -- for an IndirectCall, the callee (thunk, function value) is the *first* -- Hugr input. So move all the others along, and add that extra edge. pure $ Just (callerId, 1, [(Port calleeId outPort, 0)]) @@ -459,15 +463,15 @@ compileWithInputs parent name = gets compiled >>= (\case Source -> default_edges <$> do outs <- compilePorts outs - addNode "Input" (OpIn (InputNode parent outs [("source", "Source"), ("parent", show parent)])) + addNode "Input" (parent, OpIn (InputNode outs [("source", "Source"), ("parent", show parent)])) Target -> default_edges <$> do ins <- compilePorts ins - addNode "Output" (OpOut (OutputNode parent ins [("source", "Target")])) + addNode "Output" (parent, OpOut (OutputNode ins [("source", "Target")])) Id | Nothing <- hasPrefix ["checking", "globals", "decl"] name -> default_edges <$> do -- not a top-level decl, just compile it as an Id (TLDs handled in compileNode) let [(_,ty)] = ins -- fail if more than one input - addNode "Id" (OpNoop (NoopOp parent (compileType ty))) + addNode "Id" (parent, OpNoop (NoopOp (compileType ty))) Constructor c -> default_edges <$> do ins <- compilePorts ins @@ -478,10 +482,11 @@ compileWithInputs parent name = gets compiled >>= (\case PatternMatch cs -> default_edges <$> do ins <- compilePorts ins outs <- compilePorts outs - dfgId <- addNode "DidMatch_DFG" (OpDFG (DFG parent (FunctionType ins outs bratExts) [])) - inputNode <- addNode "PatternMatch.Input" (OpIn (InputNode dfgId ins [("source", "PatternMatch"), ("parent", show dfgId)])) + dfgId <- addNode "DidMatch_DFG" (parent, OpDFG (DFG (FunctionType ins outs bratExts) [])) + inputNode <- addNode "PatternMatch.Input" (dfgId, OpIn (InputNode ins [("source", "PatternMatch"), ("parent", show dfgId)])) + ccOuts <- compileClauses dfgId (zip (Port inputNode <$> [0..]) ins) cs - addNodeWithInputs "PatternMatch.Output" (OpOut (OutputNode dfgId (snd <$> ccOuts) [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts [] + addNodeWithInputs "PatternMatch.Output" (dfgId, OpOut (OutputNode (snd <$> ccOuts) [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts [] pure dfgId ArithNode op -> default_edges <$> compileArithNode parent op (snd $ head ins) Selector _c -> error "Todo: selector" @@ -490,7 +495,7 @@ compileWithInputs parent name = gets compiled >>= (\case let [_, elemTy] = ins outs <- compilePorts outs let sig = FunctionType ins outs bratExts - addNode "Replicate" (OpCustom (CustomOp parent "BRAT" "Replicate" sig [TAType elemTy])) + addNode "Replicate" (parent, OpCustom (CustomOp "BRAT" "Replicate" sig [TAType elemTy])) x -> error $ show x ++ " should have been compiled outside of compileNode" compileConstructor :: NodeId -> QualName -> QualName -> FunctionType -> Compile NodeId @@ -499,9 +504,9 @@ compileConstructor parent tycon con sig -- A boolean value is a tag which takes no inputs and produces an empty tuple -- This is the same thing that happens in Brat.Checker.Clauses to make the -- discriminator (makeRowTag) - addNode "bool.tag" (OpTag (TagOp parent (if b then 1 else 0) [[], []] [("hint", "bool")])) + addNode "bool.tag" (parent, OpTag (TagOp (if b then 1 else 0) [[], []] [("hint", "bool")])) | otherwise = let name = "Constructor " ++ show tycon ++ "::" ++ show con in - addNode name (constructorOp parent tycon con sig) + addNode name (parent, constructorOp tycon con sig) where isBool :: QualName -> Maybe Bool isBool CFalse = Just False @@ -535,13 +540,13 @@ compileConstDfg parent desc (inTys, outTys) contents = do -- make a DFG node at the root. We can't use `addNode` since the -- DFG needs itself as parent dfg_id <- freshNode ("Box_" ++ show desc) - addOp (OpDFG $ DFG dfg_id funTy []) dfg_id + addOp (dfg_id, OpDFG $ DFG funTy []) dfg_id contents dfg_id let nestedHugr = renameAndSortHugr (nodes cs) (edges cs) let ht = HTFunc $ PolyFuncType [] funTy - constNode <- addNode ("ConstTemplate_" ++ desc) (OpConst (ConstOp parent (HVFunction nestedHugr))) - lcPort <- head <$> addNodeWithInputs ("LoadTemplate_" ++ desc) (OpLoadConstant (LoadConstantOp parent ht)) + constNode <- addNode ("ConstTemplate_" ++ desc) (parent, OpConst (ConstOp (HVFunction nestedHugr))) + lcPort <- head <$> addNodeWithInputs ("LoadTemplate_" ++ desc) (parent, OpLoadConstant (LoadConstantOp ht)) [(Port constNode 0, ht)] [ht] pure (lcPort, a) @@ -562,7 +567,7 @@ compileBratBox parent name (venv, src, tgt) cty = do let boxInnerSig = FunctionType allInputTys outputTys bratExts (templatePort, _) <- compileConstDfg parent ("BB" ++ show name) (allInputTys, outputTys) $ \dfgId -> do - src_id <- addNode ("LiftedCapturesInputs" ++ show name) (OpIn (InputNode dfgId allInputTys [("source", "compileBratBox")])) + src_id <- addNode ("LiftedCapturesInputs" ++ show name) (dfgId, OpIn (InputNode allInputTys [("source", "compileBratBox")])) -- Now map ports in the BRAT Graph to their Hugr equivalents. -- Each captured value is read from an element of src_id, starting from 0 let lifted = [(src, Port src_id i) | ((src, _ty), i) <- zip params [0..]] @@ -574,7 +579,7 @@ compileBratBox parent name (venv, src, tgt) cty = do compileWithInputs dfgId tgt -- Finally, we add a `Partial` node to supply the captured params. - partialNode <- addNode "Partial" (OpCustom $ partialOp parent boxInnerSig (length params)) + partialNode <- addNode "Partial" (parent, OpCustom $ partialOp boxInnerSig (length params)) addEdge (fst templatePort, Port partialNode 0) edge_srcs <- for (map fst params) $ getOutPort parent pure (partialNode, zip (map fromJust edge_srcs) [1..]) @@ -603,7 +608,7 @@ compileKernBox parent name contents cty = do -- Add a substitute node to fill the holes in the template let hole_sigs = [ body poly | (_, HTFunc poly) <- hole_ports ] - head <$> addNodeWithInputs ("subst_" ++ show name) (OpCustom (substOp parent (FunctionType inTys outTys bratExts) hole_sigs)) (templatePort : hole_ports) [boxTy] + head <$> addNodeWithInputs ("subst_" ++ show name) (parent, OpCustom (substOp (FunctionType inTys outTys bratExts) hole_sigs)) (templatePort : hole_ports) [boxTy] -- We get a bunch of TypedPorts which are associated with Srcs in the BRAT graph. @@ -702,7 +707,7 @@ compileMatchSequence parent portTable (MatchSequence {..}) = do makeRowTag :: String -> NodeId -> Int -> SumOfRows -> [TypedPort] -> Compile [TypedPort] makeRowTag hint parent tag sor@(SoR sumRows) ins = if sumRows !! tag == (snd <$> ins) - then addNodeWithInputs (hint ++ "_Tag") (OpTag (TagOp parent tag sumRows [("hint", hint), ("tag", show tag), ("row", show (sumRows!!tag))])) ins [compileSumOfRows sor] + then addNodeWithInputs (hint ++ "_Tag") (parent, OpTag (TagOp tag sumRows [("hint", hint), ("tag", show tag), ("row", show (sumRows!!tag))])) ins [compileSumOfRows sor] else error $ "In makeRowTag " ++ hint ++ ", Elements " ++ show (snd <$> ins) ++ " do not match tag " ++ show tag ++ " of " ++ show sumRows getSumVariants :: HugrType -> [[HugrType]] @@ -713,7 +718,7 @@ getSumVariants ty = error $ "Expected a sum type, got " ++ show ty -- This should only be called by the logic which creates conditionals, because -- wires that exist in the brat graph are already going to be added at the end. -addNodeWithInputs :: String -> HugrOp NodeId -> [TypedPort] +addNodeWithInputs :: String -> (NodeId, HugrOp) -> [TypedPort] -> [HugrType] -- The types of the outputs -> Compile [TypedPort] -- The output wires addNodeWithInputs name op inWires outTys = do @@ -734,7 +739,7 @@ makeConditional lbl parent discrim otherInputs cases = do unless (allRowsEqual outTyss) (error "Conditional output types didn't match") - let condOp = OpConditional (Conditional parent rows (snd <$> otherInputs) (head outTyss) [("label", lbl)]) + let condOp = (parent, OpConditional (Conditional rows (snd <$> otherInputs) (head outTyss) [("label", lbl)])) addOp condOp condId addEdge (fst discrim, Port condId 0) traverse_ addEdge (zip (fst <$> otherInputs) (Port condId <$> [1..])) @@ -743,12 +748,12 @@ makeConditional lbl parent discrim otherInputs cases = do makeCase :: NodeId -> String -> Int -> [HugrType] -> (NodeId -> [TypedPort] -> Compile [TypedPort]) -> Compile [HugrType] makeCase parent name ix tys f = do caseId <- freshNode name - inpId <- addNode ("Input_" ++ name) (OpIn (InputNode caseId tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) + inpId <- addNode ("Input_" ++ name) (caseId, OpIn (InputNode tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) outs <- f caseId (zipWith (\offset ty -> (Port inpId offset, ty)) [0..] tys) let outTys = snd <$> outs - outId <- addNode ("Output" ++ name) (OpOut (OutputNode caseId outTys [("source", "makeCase")])) + outId <- addNode ("Output" ++ name) (caseId, OpOut (OutputNode outTys [("source", "makeCase")])) for_ (zip (fst <$> outs) (Port outId <$> [0..])) addEdge - addOp (OpCase (ix, Case parent (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) caseId + addOp (parent, OpCase (ix, Case (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) caseId pure outTys allRowsEqual :: [[HugrType]] -> Bool @@ -764,8 +769,8 @@ compilePrimTest parent (port, ty) (PrimCtorTest c tycon unpackingNode outputs) = let sumOut = HTSum (SG (GeneralSum [[ty], snd <$> outputs])) let sig = FunctionType [ty] [sumOut] ["BRAT"] testId <- addNode ("PrimCtorTest " ++ show c) - (OpCustom (CustomOp - parent + (parent + ,OpCustom (CustomOp "BRAT" ("PrimCtorTest::" ++ show tycon ++ "::" ++ show c) sig @@ -775,19 +780,19 @@ compilePrimTest parent (port, ty) (PrimCtorTest c tycon unpackingNode outputs) = pure (Port testId 0, sumOut) compilePrimTest parent port@(_, ty) (PrimLitTest tm) = do -- Make a Const node that holds the value we test against - constId <- addNode "LitConst" (OpConst (ConstOp parent (valFromSimple tm))) - loadPort <- head <$> addNodeWithInputs "LitLoad" (OpLoadConstant (LoadConstantOp parent ty)) + constId <- addNode "LitConst" (parent, OpConst (ConstOp (valFromSimple tm))) + loadPort <- head <$> addNodeWithInputs "LitLoad" (parent, OpLoadConstant (LoadConstantOp ty)) [(Port constId 0, ty)] [ty] -- Connect to a test node let sumOut = HTSum (SG (GeneralSum [[ty], []])) let sig = FunctionType [ty, ty] [sumOut] ["BRAT"] head <$> addNodeWithInputs ("PrimLitTest " ++ show tm) - (OpCustom (CustomOp parent "BRAT" ("PrimLitTest::" ++ show ty) sig [])) + (parent, OpCustom (CustomOp "BRAT" ("PrimLitTest::" ++ show ty) sig [])) [port, loadPort] [sumOut] -constructorOp :: NodeId -> QualName -> QualName -> FunctionType -> HugrOp NodeId -constructorOp parent tycon c sig = OpCustom (CustomOp parent "BRAT" ("Ctor::" ++ show tycon ++ "::" ++ show c) sig []) +constructorOp :: QualName -> QualName -> FunctionType -> HugrOp +constructorOp tycon c sig = OpCustom (CustomOp "BRAT" ("Ctor::" ++ show tycon ++ "::" ++ show c) sig []) undoPrimTest :: NodeId -> [TypedPort] -- The inputs we have to put back together @@ -798,13 +803,13 @@ undoPrimTest parent inPorts outTy (PrimCtorTest c tycon _ _) = do let sig = FunctionType (snd <$> inPorts) [outTy] ["BRAT"] head <$> addNodeWithInputs ("UndoCtorTest " ++ show c) - (constructorOp parent tycon c sig) + (parent, constructorOp tycon c sig) inPorts [outTy] undoPrimTest parent inPorts outTy (PrimLitTest tm) = do unless (null inPorts) $ error "Unexpected inPorts" - constId <- addNode "LitConst" (OpConst (ConstOp parent (valFromSimple tm))) - head <$> addNodeWithInputs "LitLoad" (OpLoadConstant (LoadConstantOp parent outTy)) + constId <- addNode "LitConst" (parent, OpConst (ConstOp (valFromSimple tm))) + head <$> addNodeWithInputs "LitLoad" (parent, OpLoadConstant (LoadConstantOp outTy)) [(Port constId 0, outTy)] [outTy] -- Create a module and FuncDecl nodes inside it for all of the functions given as argument @@ -816,7 +821,7 @@ compileModule venv = do -- to compute its value. bodies <- for decls (\(fnName, idNode) -> do (funTy, extra_call, body) <- analyseDecl idNode - defNode <- addNode (show fnName ++ "_def") (OpDefn $ FuncDefn moduleNode (show fnName) funTy []) + defNode <- addNode (show fnName ++ "_def") (moduleNode, OpDefn $ FuncDefn (show fnName) funTy []) registerFuncDef idNode (defNode, extra_call) pure (body defNode) ) @@ -861,8 +866,8 @@ compileModule venv = do withIO :: NodeId -> HugrType -> Compile TypedPort -> Compile () withIO parent output c = do - addNode "input" (OpIn (InputNode parent [] [("source", "analyseDecl")])) - output <- addNode "output" (OpOut (OutputNode parent [output] [("source", "analyseDecl")])) + addNode "input" (parent, OpIn (InputNode [] [("source", "analyseDecl")])) + output <- addNode "output" (parent, OpOut (OutputNode [output] [("source", "analyseDecl")])) wire <- c addEdge (fst wire, Port output 0) @@ -878,7 +883,7 @@ compileModule venv = do mkModuleNode :: Compile NodeId mkModuleNode = do id <- freshNode "module" - addOp (OpMod $ ModuleOp id) id + addOp (id, OpMod ModuleOp) id pure id funcReturning :: [HugrType] -> PolyFuncType @@ -886,8 +891,8 @@ compileModule venv = do compileNoun :: [HugrType] -> [OutPort] -> NodeId -> Compile () compileNoun outs srcPorts parent = do - addNode "input" (OpIn (InputNode parent [] [("source", "compileNoun")])) - output <- addNode "output" (OpOut (OutputNode parent outs [("source", "compileNoun")])) + addNode "input" (parent, OpIn (InputNode [] [("source", "compileNoun")])) + output <- addNode "output" (parent, OpOut (OutputNode outs [("source", "compileNoun")])) for_ (zip [0..] srcPorts) (\(outport, Ex src srcPort) -> compileWithInputs parent src >>= \case Just nodeId -> addEdge (Port nodeId srcPort, Port output outport) $> () diff --git a/brat/Data/Hugr.hs b/brat/Data/Hugr.hs index d08e6418..efa8e95d 100644 --- a/brat/Data/Hugr.hs +++ b/brat/Data/Hugr.hs @@ -63,6 +63,9 @@ data HugrType | HTFunc PolyFuncType deriving (Eq, Show) +class JSONParent n where + toJSONp :: n -> Value -> Value + instance ToJSON HugrType where toJSON HTQubit = object ["t" .= ("Q" :: Text)] toJSON (HTSum (SU (UnitSum size))) = object ["t" .= ("Sum" :: Text) @@ -225,33 +228,32 @@ valFromSimple Unit = hvUnit -------------------------------------- OPS ------------------------------------- --------------------- (Depends on HugrValue and HugrType) --------------------- -data ModuleOp node = ModuleOp { parent :: node } deriving (Eq, Functor, Show) +data ModuleOp = ModuleOp deriving (Eq, Show) -instance Eq a => Ord (ModuleOp a) where +instance Ord ModuleOp where compare _ _ = EQ -instance ToJSON node => ToJSON (ModuleOp node) where - toJSON (ModuleOp parent) = object ["parent" .= parent - ,"op" .= ("Module" :: Text) - ] +instance JSONParent ModuleOp where + toJSONp ModuleOp parent = object ["parent" .= parent + ,"op" .= ("Module" :: Text) + ] -data FuncDefn node = FuncDefn - { parent :: node - , name :: String +data FuncDefn = FuncDefn + { name :: String , signature_ :: PolyFuncType , metadata :: [(String, String)] - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq a => Ord (FuncDefn a) where +instance Ord FuncDefn where compare _ _ = EQ -instance ToJSON node => ToJSON (FuncDefn node) where - toJSON (FuncDefn { .. }) = object ["parent" .= parent - ,"op" .= ("FuncDefn" :: Text) - ,"name" .= name - ,"signature" .= signature_ - ,"metadata" .= metadata - ] +instance JSONParent FuncDefn where + toJSONp (FuncDefn { .. }) parent = object ["parent" .= parent + ,"op" .= ("FuncDefn" :: Text) + ,"name" .= name + ,"signature" .= signature_ + ,"metadata" .= metadata + ] data CustomConst where CC :: forall a. (Eq a, Show a, ToJSON a) => String -> a -> CustomConst @@ -269,67 +271,63 @@ instance ToJSON CustomConst where type ExtensionName = String -data ConstOp node = ConstOp - { parent :: node - , const :: HugrValue - } deriving (Eq, Functor, Show) +data ConstOp = ConstOp + { const :: HugrValue + } deriving (Eq, Show) -instance Eq a => Ord (ConstOp a) where +instance Ord ConstOp where compare _ _ = EQ -instance ToJSON node => ToJSON (ConstOp node) where - toJSON (ConstOp {..}) = object ["parent" .= parent - ,"op" .= ("Const" :: Text) - ,"v" .= const - ] +instance JSONParent ConstOp where + toJSONp (ConstOp {..}) parent = object ["parent" .= parent + ,"op" .= ("Const" :: Text) + ,"v" .= const + ] -data InputNode node = InputNode - { parent :: node - , types :: [HugrType] +data InputNode = InputNode + { types :: [HugrType] , metadata :: [(String, String)] - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq a => Ord (InputNode a) where +instance Ord InputNode where compare _ _ = EQ -instance ToJSON node => ToJSON (InputNode node) where - toJSON (InputNode parent types metadata) = object ["parent" .= parent - ,"op" .= ("Input" :: Text) - ,"types" .= types - ,"metadata" .= metadata - ] +instance JSONParent InputNode where + toJSONp (InputNode types metadata) parent = object ["parent" .= parent + ,"op" .= ("Input" :: Text) + ,"types" .= types + ,"metadata" .= metadata + ] -data OutputNode node = OutputNode - { parent :: node - , types :: [HugrType] +data OutputNode = OutputNode + { types :: [HugrType] , metadata :: [(String, String)] - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq a => Ord (OutputNode a) where +instance Ord OutputNode where compare _ _ = EQ -instance ToJSON node => ToJSON (OutputNode node) where - toJSON (OutputNode { .. }) = object ["parent" .= parent - ,"op" .= ("Output" :: Text) - ,"types" .= types - ,"metadata" .= metadata - ] +instance JSONParent OutputNode where + toJSONp (OutputNode { .. }) parent = object ["parent" .= parent + ,"op" .= ("Output" :: Text) + ,"types" .= types + ,"metadata" .= metadata + ] -data Conditional node = Conditional - { parent :: node - , sum_rows :: [[HugrType]] +data Conditional = Conditional + { sum_rows :: [[HugrType]] , other_inputs :: [HugrType] , outputs :: [HugrType] , metadata :: [(String, String)] - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq a => Ord (Conditional a) where +instance Ord Conditional where compare _ _ = EQ -instance ToJSON node => ToJSON (Conditional node) where - toJSON (Conditional { .. }) +instance JSONParent Conditional where + toJSONp (Conditional { .. }) parent = object ["op" .= ("Conditional" :: Text) ,"parent" .= parent ,"sum_rows" .= sum_rows @@ -339,21 +337,20 @@ instance ToJSON node => ToJSON (Conditional node) where ,"metadata" .= metadata ] -data Case node = Case - { parent :: node - , signature_ :: FunctionType +data Case = Case + { signature_ :: FunctionType , metadata :: [(String, String)] - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq node => Ord (Case node) where +instance Ord Case where compare _ _ = EQ -instance ToJSON node => ToJSON (Case node) where - toJSON (Case { .. }) = object ["op" .= ("Case" :: Text) - ,"parent" .= parent - ,"signature" .= signature_ - ,"metadata" .= metadata - ] +instance JSONParent Case where + toJSONp (Case { .. }) parent = object ["op" .= ("Case" :: Text) + ,"parent" .= parent + ,"signature" .= signature_ + ,"metadata" .= metadata + ] {- data Const = Const @@ -363,34 +360,32 @@ data Const = Const } -} -data DFG node = DFG - { parent :: node - , signature_ :: FunctionType +data DFG = DFG + { signature_ :: FunctionType , metadata :: [(String, String)] - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq node => Ord (DFG node) where +instance Ord DFG where compare _ _ = EQ -instance ToJSON node => ToJSON (DFG node) where - toJSON (DFG { .. }) = object ["op" .= ("DFG" :: Text) - ,"parent" .= parent - ,"signature" .= signature_ - ,"metadata" .= metadata - ] +instance JSONParent DFG where + toJSONp (DFG { .. }) parent = object ["op" .= ("DFG" :: Text) + ,"parent" .= parent + ,"signature" .= signature_ + ,"metadata" .= metadata + ] -data TagOp node = TagOp - { parent :: node - , tag :: Int +data TagOp = TagOp + { tag :: Int , variants :: [[HugrType]] , metadata :: [(String, String)] - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq node => Ord (TagOp node) where +instance Ord TagOp where compare _ _ = EQ -instance ToJSON node => ToJSON (TagOp node) where - toJSON (TagOp parent tag variants metadata) +instance JSONParent TagOp where + toJSONp (TagOp tag variants metadata) parent = object ["parent" .= parent ,"op" .= ("Tag" :: Text) ,"tag" .= tag @@ -398,41 +393,39 @@ instance ToJSON node => ToJSON (TagOp node) where ,"metadata" .= metadata ] -data MakeTupleOp node = MakeTupleOp - { parent :: node - , tys :: [HugrType] - } deriving (Eq, Functor, Show) +data MakeTupleOp = MakeTupleOp + { tys :: [HugrType] + } deriving (Eq, Show) -instance Eq node => Ord (MakeTupleOp node) where +instance Ord MakeTupleOp where compare _ _ = EQ -instance ToJSON node => ToJSON (MakeTupleOp node) where - toJSON (MakeTupleOp parent tys) +instance JSONParent MakeTupleOp where + toJSONp (MakeTupleOp tys) parent = object ["parent" .= parent ,"op" .= ("MakeTuple" :: Text) ,"tys" .= tys ] -data CustomOp node = CustomOp - { parent :: node - , extension :: String +data CustomOp = CustomOp + { extension :: String , op_name :: String , signature_ :: FunctionType , args :: [TypeArg] - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq node => Ord (CustomOp node) where +instance Ord CustomOp where compare _ _ = EQ -instance ToJSON node => ToJSON (CustomOp node) where - toJSON (CustomOp { .. }) = object ["parent" .= parent - ,"op" .= ("CustomOp" :: Text) - ,"description" .= ("" :: Text) - ,"extension" .= pack extension - ,"args" .= args - ,"op_name" .= pack op_name - ,"signature" .= signature_ - ] +instance JSONParent CustomOp where + toJSONp (CustomOp { .. }) parent = object ["parent" .= parent + ,"op" .= ("CustomOp" :: Text) + ,"description" .= ("" :: Text) + ,"extension" .= pack extension + ,"args" .= args + ,"op_name" .= pack op_name + ,"signature" .= signature_ + ] -- In BRAT, we're not using the type parameter machinery of hugr for -- polymorphism, so calls can just take simple signatures. @@ -442,16 +435,15 @@ instance ToJSON node => ToJSON (CustomOp node) where -- -- TODO: Instead of using hugr type args, we should be using coercions for -- polymorphic function arguments. -data CallOp node = CallOp - { parent :: node - , signature_ :: FunctionType - } deriving (Eq, Functor, Show) +data CallOp = CallOp + { signature_ :: FunctionType + } deriving (Eq, Show) -instance Eq node => Ord (CallOp node) where +instance Ord CallOp where compare _ _ = EQ -instance ToJSON node => ToJSON (CallOp node) where - toJSON (CallOp parent signature_) = +instance JSONParent CallOp where + toJSONp (CallOp signature_) parent = object ["parent" .= parent ,"op" .= ("Call" :: Text) ,"func_sig" .= PolyFuncType [] signature_ @@ -459,35 +451,34 @@ instance ToJSON node => ToJSON (CallOp node) where ,"instantiation" .= signature_ ] -intOp :: node -> String -> [HugrType] -> [HugrType] -> [TypeArg] -> CustomOp node -intOp parent opName ins outs = CustomOp parent "arithmetic.int_ops" opName (FunctionType ins outs ["arithmetic.int_ops"]) +intOp :: String -> [HugrType] -> [HugrType] -> [TypeArg] -> CustomOp +intOp opName ins outs = CustomOp "arithmetic.int_ops" opName (FunctionType ins outs ["arithmetic.int_ops"]) -binaryIntOp :: node -> String -> CustomOp node -binaryIntOp parent name - = intOp parent name [hugrInt, hugrInt] [hugrInt] [TANat intWidth] +binaryIntOp :: String -> CustomOp +binaryIntOp name + = intOp name [hugrInt, hugrInt] [hugrInt] [TANat intWidth] -floatOp :: node -> String -> [HugrType] -> [HugrType] -> [TypeArg] -> CustomOp node -floatOp parent opName ins outs = CustomOp parent "arithmetic.float_ops" opName (FunctionType ins outs ["arithmetic.float_ops"]) +floatOp :: String -> [HugrType] -> [HugrType] -> [TypeArg] -> CustomOp +floatOp opName ins outs = CustomOp "arithmetic.float_ops" opName (FunctionType ins outs ["arithmetic.float_ops"]) -binaryFloatOp :: node -> String -> CustomOp node -binaryFloatOp parent name = floatOp parent name [hugrFloat, hugrFloat] [hugrFloat] [] +binaryFloatOp :: String -> CustomOp +binaryFloatOp name = floatOp name [hugrFloat, hugrFloat] [hugrFloat] [] -data CallIndirectOp node = CallIndirectOp - { parent :: node - , signature_ :: FunctionType - } deriving (Eq, Functor, Show) +data CallIndirectOp = CallIndirectOp + { signature_ :: FunctionType + } deriving (Eq, Show) -instance Eq node => Ord (CallIndirectOp node) where +instance Ord CallIndirectOp where compare _ _ = EQ -instance ToJSON node => ToJSON (CallIndirectOp node) where - toJSON (CallIndirectOp parent signature_) = object ["parent" .= parent - ,"signature" .= signature_ - ,"op" .= ("CallIndirect" :: Text) - ] +instance JSONParent CallIndirectOp where + toJSONp (CallIndirectOp signature_) parent = object ["parent" .= parent + ,"signature" .= signature_ + ,"op" .= ("CallIndirect" :: Text) + ] -holeOp :: node -> Int -> FunctionType -> CustomOp node -holeOp parent idx sig = CustomOp parent "BRAT" "Hole" sig +holeOp :: Int -> FunctionType -> CustomOp +holeOp idx sig = CustomOp "BRAT" "Hole" sig [TANat idx, TAType (HTFunc (PolyFuncType [] sig))] -- TYPE ARGS: @@ -500,12 +491,11 @@ holeOp parent idx sig = CustomOp parent "BRAT" "Hole" sig -- * Many graphs with types given by innerSigs (to go in the holes) -- OUTPUT: -- * A single graph whose signature is the same as outerSig -substOp :: node - -> {- outerSig :: -}FunctionType +substOp :: {- outerSig :: -}FunctionType -> {- innerSigs :: -}[FunctionType]{- length n -} - -> CustomOp node -substOp parent outerSig innerSigs - = CustomOp parent "BRAT" "Substitute" sig [toArg outerSig, TASequence (toArg <$> innerSigs)] + -> CustomOp +substOp outerSig innerSigs + = CustomOp "BRAT" "Substitute" sig [toArg outerSig, TASequence (toArg <$> innerSigs)] where fnExts (FunctionType _ _ exts) = S.fromList exts combinedExts = S.toList $ foldr S.union (fnExts outerSig) (fnExts <$> innerSigs) @@ -519,11 +509,10 @@ toFunc ty = HTFunc (PolyFuncType [] ty) toSeq :: [HugrType] -> TypeArg toSeq tys = TASequence (TAType <$> tys) -partialOp :: node -- Parent - -> FunctionType -- Signature of the function that is partially evaluated +partialOp :: FunctionType -- Signature of the function that is partially evaluated -> Int -- Number of arguments that are evaluated - -> CustomOp node -partialOp parent funcSig numSupplied = CustomOp parent "BRAT" "Partial" sig args + -> CustomOp +partialOp funcSig numSupplied = CustomOp "BRAT" "Partial" sig args where sig :: FunctionType sig = FunctionType @@ -536,76 +525,73 @@ partialOp parent funcSig numSupplied = CustomOp parent "BRAT" "Partial" sig args otherInputs = drop numSupplied (input funcSig) -data LoadConstantOp node = LoadConstantOp - { parent :: node - , datatype :: HugrType - } deriving (Eq, Functor, Show) +data LoadConstantOp = LoadConstantOp + { datatype :: HugrType + } deriving (Eq, Show) -instance Eq node => Ord (LoadConstantOp node) where +instance Ord LoadConstantOp where compare _ _ = EQ -instance ToJSON node => ToJSON (LoadConstantOp node) where - toJSON (LoadConstantOp {..}) = object ["parent" .= parent - ,"op" .= ("LoadConstant" :: Text) - ,"datatype" .= datatype - ] +instance JSONParent LoadConstantOp where + toJSONp (LoadConstantOp {..}) parent = object ["parent" .= parent + ,"op" .= ("LoadConstant" :: Text) + ,"datatype" .= datatype + ] -data LoadFunctionOp node = LoadFunctionOp - { parent :: node - , func_sig :: PolyFuncType +data LoadFunctionOp = LoadFunctionOp + { func_sig :: PolyFuncType , type_args :: [TypeArg] , signature :: FunctionType - } deriving (Eq, Functor, Show) + } deriving (Eq, Show) -instance Eq node => Ord (LoadFunctionOp node) where +instance Ord LoadFunctionOp where compare _ _ = EQ -instance ToJSON node => ToJSON (LoadFunctionOp node) where - toJSON (LoadFunctionOp {..}) = object ["parent" .= parent - ,"op" .= ("LoadFunction" :: Text) - ,"func_sig" .= func_sig - ,"type_args" .= type_args - ,"signature" .= signature - ] +instance JSONParent LoadFunctionOp where + toJSONp (LoadFunctionOp {..}) parent = object ["parent" .= parent + ,"op" .= ("LoadFunction" :: Text) + ,"func_sig" .= func_sig + ,"type_args" .= type_args + ,"signature" .= signature + ] -data NoopOp node = NoopOp - { parent :: node - , ty :: HugrType - } deriving (Eq, Functor, Show) +data NoopOp = NoopOp + { ty :: HugrType + } deriving (Eq, Show) -instance Eq node => Ord (NoopOp node) where +instance Ord NoopOp where compare _ _ = EQ -instance ToJSON node => ToJSON (NoopOp node) where - toJSON (NoopOp {..}) = object ["parent" .= parent - ,"op" .= ("Noop" :: Text) - ,"ty" .= ty - ] +instance JSONParent NoopOp where + toJSONp (NoopOp {..}) parent = object ["parent" .= parent + ,"op" .= ("Noop" :: Text) + ,"ty" .= ty + ] -- In the order they must be printed in - roots, inputs, outputs -data HugrOp node +data HugrOp -- OpConditional should be compiled last so we can sort out its parent - = OpMod (ModuleOp node) - | OpIn (InputNode node) - | OpOut (OutputNode node) + = OpMod ModuleOp + | OpIn InputNode + | OpOut OutputNode -- the rest - | OpDefn (FuncDefn node) - | OpDFG (DFG node) - | OpConst (ConstOp node) - | OpConditional (Conditional node) + | OpDefn FuncDefn + | OpDFG DFG + | OpConst ConstOp + | OpConditional Conditional -- Make sure that the cases are printed out in the correct order - | OpCase (Int, Case node) - | OpTag (TagOp node) - | OpMakeTuple (MakeTupleOp node) - | OpCustom (CustomOp node) - | OpCall (CallOp node) - | OpCallIndirect (CallIndirectOp node) - | OpLoadConstant (LoadConstantOp node) - | OpLoadFunction (LoadFunctionOp node) - | OpNoop (NoopOp node) - deriving (Eq, Functor, Ord, Show) - -addMetadata :: [(String, String)] -> HugrOp node -> HugrOp node + | OpCase (Int, Case) + | OpTag TagOp + | OpMakeTuple MakeTupleOp + | OpCustom CustomOp + | OpCall CallOp + | OpCallIndirect CallIndirectOp + | OpLoadConstant LoadConstantOp + | OpLoadFunction LoadFunctionOp + | OpNoop NoopOp + deriving (Eq, Ord, Show) + +addMetadata :: [(String, String)] -> HugrOp -> HugrOp addMetadata md (OpDFG (DFG { .. })) = OpDFG (DFG { metadata = metadata ++ md, .. }) addMetadata md (OpCase (i, (Case { .. }))) = OpCase (i, (Case { metadata = metadata ++ md, .. })) addMetadata md (OpIn (InputNode { .. })) = OpIn (InputNode { metadata = metadata ++ md, .. }) @@ -614,48 +600,30 @@ addMetadata md (OpDefn (FuncDefn { .. })) = OpDefn (FuncDefn { metadata = metada addMetadata md (OpConditional (Conditional { .. })) = OpConditional (Conditional { metadata = metadata ++ md, .. }) addMetadata _ op = op -instance ToJSON node => ToJSON (HugrOp node) where - toJSON (OpMod op) = toJSON op - toJSON (OpDefn op) = toJSON op - toJSON (OpConst op) = toJSON op - toJSON (OpDFG op) = toJSON op - toJSON (OpIn op) = toJSON op - toJSON (OpOut op) = toJSON op - toJSON (OpCase (_, op)) = toJSON op - toJSON (OpConditional op) = toJSON op - toJSON (OpTag op) = toJSON op - toJSON (OpMakeTuple op) = toJSON op - toJSON (OpCustom op) = toJSON op - toJSON (OpCall op) = toJSON op - toJSON (OpCallIndirect op) = toJSON op - toJSON (OpLoadConstant op) = toJSON op - toJSON (OpLoadFunction op) = toJSON op - toJSON (OpNoop op) = toJSON op - -getParent :: HugrOp node -> node -getParent (OpMod (ModuleOp { parent = parent })) = parent -getParent (OpDefn (FuncDefn { parent = parent })) = parent -getParent (OpConst (ConstOp { parent = parent })) = parent -getParent (OpDFG (DFG { parent = parent })) = parent -getParent (OpConditional (Conditional { parent = parent })) = parent -getParent (OpCase (_, Case { parent = parent })) = parent -getParent (OpIn (InputNode { parent = parent })) = parent -getParent (OpOut (OutputNode { parent = parent })) = parent -getParent (OpTag (TagOp { parent = parent })) = parent -getParent (OpMakeTuple (MakeTupleOp { parent = parent })) = parent -getParent (OpCustom (CustomOp { parent = parent })) = parent -getParent (OpCall (CallOp { parent = parent })) = parent -getParent (OpCallIndirect (CallIndirectOp { parent = parent })) = parent -getParent (OpLoadConstant (LoadConstantOp { parent = parent })) = parent -getParent (OpLoadFunction (LoadFunctionOp { parent = parent })) = parent -getParent (OpNoop (NoopOp { parent = parent })) = parent - -data Hugr node = Hugr [HugrOp node] [(PortId node, PortId node)] +instance JSONParent HugrOp where + toJSONp (OpMod op) parent = toJSONp op parent + toJSONp (OpDefn op) parent = toJSONp op parent + toJSONp (OpConst op) parent = toJSONp op parent + toJSONp (OpDFG op) parent = toJSONp op parent + toJSONp (OpIn op) parent = toJSONp op parent + toJSONp (OpOut op) parent = toJSONp op parent + toJSONp (OpCase (_, op)) parent = toJSONp op parent + toJSONp (OpConditional op) parent = toJSONp op parent + toJSONp (OpTag op) parent = toJSONp op parent + toJSONp (OpMakeTuple op) parent = toJSONp op parent + toJSONp (OpCustom op) parent = toJSONp op parent + toJSONp (OpCall op) parent = toJSONp op parent + toJSONp (OpCallIndirect op) parent = toJSONp op parent + toJSONp (OpLoadConstant op) parent = toJSONp op parent + toJSONp (OpLoadFunction op) parent = toJSONp op parent + toJSONp (OpNoop op) parent = toJSONp op parent + +data Hugr node = Hugr [(node, HugrOp)] [(PortId node, PortId node)] deriving (Eq, Functor, Show) instance ToJSON node => ToJSON (Hugr node) where toJSON (Hugr ns es) = object ["version" .= ("v1" :: Text) - ,"nodes" .= ns + ,"nodes" .= [toJSONp op (toJSON node) | (node, op) <- ns] ,"edges" .= es ,"encoder" .= ("BRAT" :: Text) ] From 8b26471a99d69bcc65c8966caf342c9b5491bf20 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 16 Dec 2025 21:22:32 +0000 Subject: [PATCH 002/149] Make abstract datatype for Hugr --- brat/Brat/Compile/Hugr.hs | 110 ++++++++++++++------------------------ brat/Data/Hugr.hs | 42 +++++++-------- brat/Data/HugrGraph.hs | 76 ++++++++++++++++++++++++++ brat/brat.cabal | 1 + 4 files changed, 137 insertions(+), 92 deletions(-) create mode 100644 brat/Data/HugrGraph.hs diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 9b0d4f9e..7b0de144 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -24,6 +24,7 @@ import Brat.Syntax.Value import Bwd import Control.Monad.Freer import Data.Hugr +import qualified Data.HugrGraph as H import Hasochism import Control.Monad (unless) @@ -32,7 +33,7 @@ import Data.Bifunctor (first, second) import qualified Data.ByteString.Lazy as BS import Data.Foldable (traverse_, for_) import Data.Functor ((<&>), ($>)) -import Data.List (partition, sort, sortBy) +import Data.List (sortBy) import qualified Data.Map as M import Data.Maybe (catMaybes, fromJust, isJust) import Data.Ord (comparing) @@ -40,7 +41,6 @@ import Data.Traversable (for) import Control.Monad.State import Data.List.NonEmpty (NonEmpty, nonEmpty) import GHC.Base (NonEmpty(..)) -import Data.Tuple (swap) {- For each top level function definition or value in BRAT: we should have a FuncDef node in @@ -55,8 +55,7 @@ data CompilationState = CompilationState { bratGraph :: Graph -- the input BRAT Graph; should not be written , capSets :: CaptureSets -- environments captured by Box nodes in previous , nameSupply :: Namespace - , nodes :: M.Map NodeId (NodeId, HugrOp) -- this node's id => HugrOp containing parent id - , edges :: [(PortId NodeId, PortId NodeId)] + , hugr :: H.Hugr NodeId , compiled :: M.Map Name NodeId -- Mapping from Brat nodes to Hugr nodes -- When lambda lifting, captured variables become extra function inputs. -- This maps from the captured value (in the BRAT graph, perhaps outside the current func/lambda) @@ -72,12 +71,11 @@ data CompilationState = CompilationState , decls :: M.Map Name (NodeId, Bool) } -emptyCS g cs ns store = CompilationState +makeCS (g, cs, ns, store) rootName rootOp = CompilationState { bratGraph = g , capSets = cs , nameSupply = ns - , nodes = M.empty - , edges = [] + , hugr = H.newWithRoot rootName rootOp , compiled = M.empty , holes = B0 , liftedOutPorts = M.empty @@ -100,10 +98,7 @@ freshNode str = do pure (NodeId freshName) addEdge :: (PortId NodeId, PortId NodeId) -> Compile () -addEdge e = do - st <- get - let es = edges st - put (st { edges = e:es }) +addEdge e = get >>= \st -> put (st { hugr = H.addEdge (hugr st) e }) addNode :: String -> (NodeId, HugrOp) -> Compile NodeId addNode name (parent, op) = do @@ -183,10 +178,7 @@ compilePorts = compileGraphTypes . map snd addOp :: (NodeId, HugrOp) -> NodeId -> Compile () addOp op name | track ("addOp " ++ show op ++ show name) False = undefined -addOp op name = do - st <- get - let new_nodes = M.alter (\Nothing -> Just op) name (nodes st) -- fail if key already present - put (st { nodes = new_nodes }) +addOp op name = get >>= \st -> put (st { hugr = H.addOp (hugr st) name op }) registerCompiled :: Name -> NodeId -> Compile () registerCompiled from to | track (show from ++ " |-> " ++ show to) False = undefined @@ -229,52 +221,35 @@ compileArithNode parent op TFloat = addNode (show op ++ "_Float") (parent, OpCus ) compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty -renameAndSortHugr :: M.Map NodeId (NodeId, HugrOp) -> [(PortId NodeId, PortId NodeId)] -> Hugr Int -renameAndSortHugr nodes edges = indexMetadata $ fmap update (Hugr (swap . fst <$> sorted_nodes) (edges ++ orderEdges)) where - indexMetadata :: Hugr Int -> Hugr Int - indexMetadata (Hugr ops edges) = Hugr [(p, addMetadata [("index", show ix)] op) | (ix, (p, op)) <- zip [0..] ops] edges - - sorted_nodes :: [((HugrOp, NodeId), NodeId)] -- (op, parent), name - sorted_nodes = let ([root], rest) = partition (\((_op, parent), nid) -> nid == parent) - [((op, parent), nid) | (nid, (parent, op)) <- M.assocs nodes] - in root : (sort rest) -- sort rest by op - - names2Pos = M.fromList $ zip (snd <$> sorted_nodes) ([0..] :: [Int]) - parentOf n = let (parent, _) = (nodes M.! n) in parent - - update :: NodeId -> Int - update name = case M.lookup name names2Pos of - Just ans -> ans - Nothing -> error ("Couldn't find node " ++ show name ++ "???") - - orderEdges :: [(PortId NodeId, PortId NodeId)] +renameAndSortHugr :: H.Hugr NodeId -> Hugr Int +renameAndSortHugr hugr = H.serialize (foldl H.addOrderEdge hugr orderEdges) + where + orderEdges :: [(NodeId, NodeId)] orderEdges = -- Nonlocal edges (from a node to another which is a *descendant* of a sibling of the source) -- require an extra order edge from the source to the sibling that is ancestor of the target - let interEdges = [(n1, n2) | (Port n1 _, Port n2 _) <- edges, - parentOf n1 /= parentOf n2 , - requiresOrderEdge (nodes M.! n1), - requiresOrderEdge (nodes M.! n2) ] in - [(Port src orderEdgeOffset, Port tgt orderEdgeOffset) | (src, tgt) <- walkUp <$> interEdges] - - requiresOrderEdge :: (NodeId, HugrOp) -> Bool - requiresOrderEdge (_, OpMod _) = False - requiresOrderEdge (_, OpDefn _) = False - requiresOrderEdge (_, OpConst _) = False + let interEdges = [(n1, n2) | (Port n1 _, Port n2 _) <- H.edgeList hugr, + (parentOf n1 /= parentOf n2), + requiresOrderEdge (H.getOp hugr n1), + requiresOrderEdge (H.getOp hugr n2)] in + track ("interEdges: " ++ show interEdges) (walkUp <$> interEdges) + + requiresOrderEdge :: HugrOp -> Bool + requiresOrderEdge (OpMod _) = False + requiresOrderEdge (OpDefn _) = False + requiresOrderEdge (OpConst _) = False requiresOrderEdge _ = True + parentOf = H.getParent hugr + -- Walk up the hierarchy from the tgt until we hit a node at the same level as src walkUp :: (NodeId, NodeId) -> (NodeId, NodeId) walkUp (src, tgt) | parentOf src == parentOf tgt = (src, tgt) walkUp (_, tgt) | parentOf tgt == tgt = error "Tgt was not descendant of Src-parent" walkUp (src, tgt) = walkUp (src, parentOf tgt) - dumpJSON :: Compile BS.ByteString -dumpJSON = do - ns <- gets nodes - es <- gets edges - pure $ encode (renameAndSortHugr ns es) +dumpJSON = gets hugr <&> (encode . renameAndSortHugr) compileClauses :: NodeId -> [TypedPort] -> NonEmpty (TestMatchData m, Name) -> Compile [TypedPort] compileClauses parent ins ((matchData, rhs) :| clauses) = do @@ -484,7 +459,6 @@ compileWithInputs parent name = gets compiled >>= (\case outs <- compilePorts outs dfgId <- addNode "DidMatch_DFG" (parent, OpDFG (DFG (FunctionType ins outs bratExts) [])) inputNode <- addNode "PatternMatch.Input" (dfgId, OpIn (InputNode ins [("source", "PatternMatch"), ("parent", show dfgId)])) - ccOuts <- compileClauses dfgId (zip (Port inputNode <$> [0..]) ins) cs addNodeWithInputs "PatternMatch.Output" (dfgId, OpOut (OutputNode (snd <$> ccOuts) [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts [] pure dfgId @@ -534,15 +508,13 @@ compileConstDfg parent desc (inTys, outTys) contents = do cs <- gets capSets let funTy = FunctionType inTys outTys bratExts -- First, we fork off a new namespace - (a, cs) <- desc -! do + (a, compState) <- desc -! do + dfg_id <- freshNode ("Box_" ++ show desc) ns <- gets nameSupply - pure $ flip runState (emptyCS g cs ns st) $ do - -- make a DFG node at the root. We can't use `addNode` since the - -- DFG needs itself as parent - dfg_id <- freshNode ("Box_" ++ show desc) - addOp (dfg_id, OpDFG $ DFG funTy []) dfg_id - contents dfg_id - let nestedHugr = renameAndSortHugr (nodes cs) (edges cs) + -- And pass that namespace into nested monad that compiles the DFG + let nestedState = makeCS (g,cs,ns,st) dfg_id (OpDFG $ DFG funTy []) + pure $ runState (contents dfg_id) nestedState + let nestedHugr = renameAndSortHugr (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy constNode <- addNode ("ConstTemplate_" ++ desc) (parent, OpConst (ConstOp (HVFunction nestedHugr))) @@ -813,10 +785,9 @@ undoPrimTest parent inPorts outTy (PrimLitTest tm) = do [(Port constId 0, outTy)] [outTy] -- Create a module and FuncDecl nodes inside it for all of the functions given as argument -compileModule :: VEnv +compileModule :: VEnv -> NodeId -> Compile () -compileModule venv = do - moduleNode <- mkModuleNode +compileModule venv moduleNode = do -- Prepare FuncDef nodes for all functions. Every "noun" also requires a Function -- to compute its value. bodies <- for decls (\(fnName, idNode) -> do @@ -880,12 +851,6 @@ compileModule venv = do Just _ -> pure (fnName, idNode) -- assume all ports are 0,1,2... Nothing -> [] - mkModuleNode :: Compile NodeId - mkModuleNode = do - id <- freshNode "module" - addOp (id, OpMod ModuleOp) id - pure id - funcReturning :: [HugrType] -> PolyFuncType funcReturning outs = PolyFuncType [] (FunctionType [] outs bratExts) @@ -905,11 +870,14 @@ compile :: Store -> CaptureSets -> VEnv -> BS.ByteString -compile store ns g capSets venv - = evalState +compile store ns g capSets venv = + let + (moduleName, ns') = fresh "module" ns + moduleNode = NodeId moduleName + in evalState (trackM "compileFunctions" *> - compileModule venv *> + compileModule venv moduleNode *> trackM "dumpJSON" *> dumpJSON ) - (emptyCS g capSets ns store) + (makeCS (g, capSets, ns', store) moduleNode (OpMod ModuleOp)) diff --git a/brat/Data/Hugr.hs b/brat/Data/Hugr.hs index efa8e95d..3cbff595 100644 --- a/brat/Data/Hugr.hs +++ b/brat/Data/Hugr.hs @@ -14,6 +14,19 @@ import Data.Text (Text, pack) import Brat.Syntax.Simple +orderEdgeOffset :: Int +orderEdgeOffset = -1 + +data PortId node = Port + { nodeId :: node + , offset :: Int + } + deriving (Eq, Functor, Show) + +instance ToJSON node => ToJSON (PortId node) where + toJSON (Port node offset) = toJSON (node, offset') + where offset' = if offset == orderEdgeOffset then Nothing else Just offset + -- We should be able to work out exact extension requirements for our functions, -- but instead we'll overapproximate. bratExts :: [ExtensionId] @@ -618,25 +631,12 @@ instance JSONParent HugrOp where toJSONp (OpLoadFunction op) parent = toJSONp op parent toJSONp (OpNoop op) parent = toJSONp op parent -data Hugr node = Hugr [(node, HugrOp)] [(PortId node, PortId node)] - deriving (Eq, Functor, Show) +data Hugr node = Hugr ([(node, HugrOp)], [(PortId node, PortId node)]) deriving (Eq, Show) -instance ToJSON node => ToJSON (Hugr node) where - toJSON (Hugr ns es) = object ["version" .= ("v1" :: Text) - ,"nodes" .= [toJSONp op (toJSON node) | (node, op) <- ns] - ,"edges" .= es - ,"encoder" .= ("BRAT" :: Text) - ] - -orderEdgeOffset :: Int -orderEdgeOffset = -1 - -data PortId node = Port - { nodeId :: node - , offset :: Int - } - deriving (Eq, Functor, Show) - -instance ToJSON node => ToJSON (PortId node) where - toJSON (Port node offset) = toJSON (node, offset') - where offset' = if offset == orderEdgeOffset then Nothing else Just offset +instance ToJSON (Hugr Int) where + toJSON (Hugr (nodes, edges)) = object + ["version" .= ("v1" :: Text) + ,"nodes" .= [toJSONp op (toJSON parent) | (parent, op) <- nodes] + ,"edges" .= edges + ,"encoder" .= ("BRAT" :: Text) + ] diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs new file mode 100644 index 00000000..f242f75c --- /dev/null +++ b/brat/Data/HugrGraph.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.HugrGraph(Hugr, PortId(..), + newWithRoot, addOp, getParent, getOp, + addEdge, addOrderEdge, edgeList, + serialize + ) where + +import Data.Hugr hiding (Hugr) +import qualified Data.Hugr as D +import Data.List (partition, sortBy) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import qualified Data.Map as M + +data Hugr node = HugrGraph { + -- the values here are (parent, op). + -- exactly one node (the root) will have parent == self + nodes :: M.Map node (node, HugrOp), + edges_out :: M.Map node [(Int, PortId node)], + edges_in :: M.Map node [(PortId node, Int)] +} deriving (Eq, Show) -- we probably want a better `show` + +addOp :: Ord node => Hugr node -> node -> (node, HugrOp) -> Hugr node +-- Do not insist the parent exists, we are not there yet +addOp h@HugrGraph {nodes} name weight = + -- alter + partial match is just to fail if key already present + h { nodes = M.alter (\Nothing -> Just weight) name nodes } + +newWithRoot :: node -> HugrOp -> Hugr node +newWithRoot name op = HugrGraph { + nodes = M.singleton name (name, op), + edges_in = M.empty, + edges_out = M.empty +} + +addEdge :: Ord node => Hugr node -> (PortId node, PortId node) -> Hugr node +addEdge HugrGraph {..} (src@(Port s o), tgt@(Port t i)) = case (M.lookup s nodes, M.lookup t nodes) of + (Just _, Just _) -> HugrGraph { + nodes, + edges_out = addToMap s (o, tgt) edges_out, + edges_in = addToMap t (src, i) edges_in + } + _ -> error "addEdge to/from node not present" + where + addToMap :: Ord k => k -> v -> M.Map k [v] -> M.Map k [v] + addToMap k v m = M.insert k (v:(fromMaybe [] $ M.lookup k m)) m + +addOrderEdge :: Ord node => Hugr node -> (node, node) -> Hugr node +addOrderEdge h (src, tgt) = addEdge h (Port src orderEdgeOffset, Port tgt orderEdgeOffset) + +edgeList :: Hugr node -> [(PortId node, PortId node)] +edgeList (HugrGraph {edges_out}) = [(Port n off, tgt) | (n, vs) <- M.assocs edges_out + , (off, tgt) <- vs + ] + +getParent :: Ord node => Hugr node -> node -> node +getParent HugrGraph {nodes} n = let (parent, _) = nodes M.! n in parent + +getOp :: Ord node => Hugr node -> node -> HugrOp +getOp HugrGraph {nodes} n = let (_, op) = nodes M.! n in op + +serialize :: forall node. Ord node => Hugr node -> D.Hugr Int +serialize hugr@(HugrGraph {nodes}) = D.Hugr ( + [(transNode parent, op) | (parent, op) <- snd <$> sortedNodes], + [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] + ) where + sortOrder :: (node, (node, HugrOp)) -> (HugrOp, node, node) + sortOrder (name, (parent, op)) = (op, parent, name) + + sortedNodes :: [(node, (node, HugrOp))] + sortedNodes = let isRoot (name, (parent, _op)) = name == parent + ([root], rest) = partition isRoot (M.assocs nodes) + in (root:(sortBy (comparing sortOrder) rest)) + + transNode :: node -> Int + transNode = ((M.fromList $ zip (fst <$> sortedNodes) [0..]) M.!) diff --git a/brat/brat.cabal b/brat/brat.cabal index aded7927..81e57265 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -90,6 +90,7 @@ library Bwd, Control.Monad.Freer, Data.Hugr, + Data.HugrGraph, Hasochism, Util From 990e261bb084b2241d3ef6aa95f89f9b3c4c7e2a Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 16 Dec 2025 21:23:36 +0000 Subject: [PATCH 003/149] WIP inline the one -!, abandon FreshMonad --- brat/Brat/Compile/Hugr.hs | 32 +++++++++----------------------- 1 file changed, 9 insertions(+), 23 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 7b0de144..1fc75d9b 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -108,23 +108,6 @@ addNode name (parent, op) = do type Compile = State CompilationState -instance FreshMonad Compile where - freshName x = do - s <- get - let (name, newSupply) = fresh x (nameSupply s) - put (s { nameSupply = newSupply }) - pure name - - x -! c = do - s <- get - let (nsx, nsNew) = split x (nameSupply s) - put (s { nameSupply = nsx }) - v <- c - put (s { nameSupply = nsNew }) - pure v - - whoAmI = gets (fst . nameSupply) - runCheckingInCompile :: Free CheckingSig t -> Compile t runCheckingInCompile (Ret t) = pure t runCheckingInCompile (Req (ELup e) k) = do @@ -508,12 +491,15 @@ compileConstDfg parent desc (inTys, outTys) contents = do cs <- gets capSets let funTy = FunctionType inTys outTys bratExts -- First, we fork off a new namespace - (a, compState) <- desc -! do - dfg_id <- freshNode ("Box_" ++ show desc) - ns <- gets nameSupply - -- And pass that namespace into nested monad that compiles the DFG - let nestedState = makeCS (g,cs,ns,st) dfg_id (OpDFG $ DFG funTy []) - pure $ runState (contents dfg_id) nestedState + s <- get + let (nsx, nsNew) = split desc (nameSupply s) + put (s { nameSupply = nsx }) + dfg_id <- freshNode ("Box_" ++ show desc) + ns <- gets nameSupply + -- And pass that namespace into nested monad that compiles the DFG + let nestedState = makeCS (g,cs,ns,st) dfg_id (OpDFG $ DFG funTy []) + let (a, compState) = runState (contents dfg_id) nestedState + put (s { nameSupply = nsNew }) let nestedHugr = renameAndSortHugr (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy From 214333b9676054c928fac26e49efad7571020c9b Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 16 Dec 2025 21:25:49 +0000 Subject: [PATCH 004/149] Fix Hugr on NodeId, move Namespace inside -> freshNodeWithParent --- brat/Brat/Compile/Hugr.hs | 87 +++++++++++++-------------- brat/Data/HugrGraph.hs | 120 ++++++++++++++++++++++++-------------- 2 files changed, 117 insertions(+), 90 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 1fc75d9b..4a1b1785 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -24,6 +24,7 @@ import Brat.Syntax.Value import Bwd import Control.Monad.Freer import Data.Hugr +import Data.HugrGraph (NodeId) import qualified Data.HugrGraph as H import Hasochism @@ -47,15 +48,12 @@ For each top level function definition or value in BRAT: we should have a FuncDe hugr, whose child graph is the body of the function -} -newtype NodeId = NodeId Name deriving (Eq, Ord, Show) - type TypedPort = (PortId NodeId, HugrType) data CompilationState = CompilationState { bratGraph :: Graph -- the input BRAT Graph; should not be written , capSets :: CaptureSets -- environments captured by Box nodes in previous - , nameSupply :: Namespace - , hugr :: H.Hugr NodeId + , hugr :: H.Hugr , compiled :: M.Map Name NodeId -- Mapping from Brat nodes to Hugr nodes -- When lambda lifting, captured variables become extra function inputs. -- This maps from the captured value (in the BRAT graph, perhaps outside the current func/lambda) @@ -71,40 +69,42 @@ data CompilationState = CompilationState , decls :: M.Map Name (NodeId, Bool) } -makeCS (g, cs, ns, store) rootName rootOp = CompilationState - { bratGraph = g - , capSets = cs - , nameSupply = ns - , hugr = H.newWithRoot rootName rootOp - , compiled = M.empty - , holes = B0 - , liftedOutPorts = M.empty - , store = store - , decls = M.empty - } +makeCS :: (Graph, CaptureSets, Namespace, Store) -> String -> HugrOp -> (NodeId, CompilationState) +makeCS (g, cs, ns, store) rootNam rootOp = + let (hugr, rootNode) = H.newWithRoot ns rootNam rootOp + in (rootNode + ,CompilationState + { bratGraph = g + , capSets = cs + , hugr = hugr + , compiled = M.empty + , holes = B0 + , liftedOutPorts = M.empty + , store = store + , decls = M.empty + } + ) registerFuncDef :: Name -> (NodeId, Bool) -> Compile () registerFuncDef name hugrDef = do st <- get put (st { decls = M.insert name hugrDef (decls st) }) - -freshNode :: String -> Compile NodeId -freshNode str = do - st <- get - let ns = nameSupply st - let (freshName, newSupply) = fresh str ns - put (st { nameSupply = newSupply }) - pure (NodeId freshName) +freshNodeWithParent :: String -> NodeId -> Compile NodeId +freshNodeWithParent name parent = do + s <- get + let (id, h) = H.freshNodeWithParent (hugr s) parent name + put s {hugr = h} + pure id addEdge :: (PortId NodeId, PortId NodeId) -> Compile () addEdge e = get >>= \st -> put (st { hugr = H.addEdge (hugr st) e }) addNode :: String -> (NodeId, HugrOp) -> Compile NodeId -addNode name (parent, op) = do - id <- freshNode name - addOp (parent, addMetadata [("id", show id)] op) id - pure id +addNode nam (parent, op) = do + name <- freshNodeWithParent nam parent + setOp name (addMetadata [("id", show name)] op) + pure name type Compile = State CompilationState @@ -159,9 +159,9 @@ compileGraphTypes = traverse ((<&> compileType) . runCheckingInCompile . eval S0 compilePorts :: [(a, Val Z)] -> Compile [HugrType] compilePorts = compileGraphTypes . map snd -addOp :: (NodeId, HugrOp) -> NodeId -> Compile () -addOp op name | track ("addOp " ++ show op ++ show name) False = undefined -addOp op name = get >>= \st -> put (st { hugr = H.addOp (hugr st) name op }) +setOp :: NodeId -> HugrOp -> Compile () +setOp name op | track ("addOp " ++ show op ++ show name) False = undefined +setOp name op = get >>= \st -> put (st { hugr = H.setOp (hugr st) name op }) registerCompiled :: Name -> NodeId -> Compile () registerCompiled from to | track (show from ++ " |-> " ++ show to) False = undefined @@ -204,7 +204,7 @@ compileArithNode parent op TFloat = addNode (show op ++ "_Float") (parent, OpCus ) compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty -renameAndSortHugr :: H.Hugr NodeId -> Hugr Int +renameAndSortHugr :: H.Hugr -> Hugr Int renameAndSortHugr hugr = H.serialize (foldl H.addOrderEdge hugr orderEdges) where orderEdges :: [(NodeId, NodeId)] @@ -492,14 +492,11 @@ compileConstDfg parent desc (inTys, outTys) contents = do let funTy = FunctionType inTys outTys bratExts -- First, we fork off a new namespace s <- get - let (nsx, nsNew) = split desc (nameSupply s) - put (s { nameSupply = nsx }) - dfg_id <- freshNode ("Box_" ++ show desc) - ns <- gets nameSupply + let (nsx, hugr') = H.splitNamespace (hugr s) desc + put s {hugr=hugr'} -- And pass that namespace into nested monad that compiles the DFG - let nestedState = makeCS (g,cs,ns,st) dfg_id (OpDFG $ DFG funTy []) + let (dfg_id, nestedState) = makeCS (g,cs,nsx,st) ("Box_" ++ show desc) (OpDFG $ DFG funTy []) let (a, compState) = runState (contents dfg_id) nestedState - put (s { nameSupply = nsNew }) let nestedHugr = renameAndSortHugr (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy @@ -691,27 +688,27 @@ makeConditional :: String -- Label -> [(String, NodeId -> [TypedPort] -> Compile [TypedPort])] -- Must be ordered -> Compile [TypedPort] makeConditional lbl parent discrim otherInputs cases = do - condId <- freshNode "Conditional" + condId <- freshNodeWithParent "Conditional" parent let rows = getSumVariants (snd discrim) outTyss <- for (zip (zip [0..] cases) rows) (\((ix, (name, f)), row) -> makeCase condId name ix (row ++ (snd <$> otherInputs)) f) unless (allRowsEqual outTyss) (error "Conditional output types didn't match") - let condOp = (parent, OpConditional (Conditional rows (snd <$> otherInputs) (head outTyss) [("label", lbl)])) - addOp condOp condId + let condOp = OpConditional (Conditional rows (snd <$> otherInputs) (head outTyss) [("label", lbl)]) + setOp condId condOp addEdge (fst discrim, Port condId 0) traverse_ addEdge (zip (fst <$> otherInputs) (Port condId <$> [1..])) pure $ zip (Port condId <$> [0..]) (head outTyss) where makeCase :: NodeId -> String -> Int -> [HugrType] -> (NodeId -> [TypedPort] -> Compile [TypedPort]) -> Compile [HugrType] makeCase parent name ix tys f = do - caseId <- freshNode name + caseId <- freshNodeWithParent name parent inpId <- addNode ("Input_" ++ name) (caseId, OpIn (InputNode tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) outs <- f caseId (zipWith (\offset ty -> (Port inpId offset, ty)) [0..] tys) let outTys = snd <$> outs outId <- addNode ("Output" ++ name) (caseId, OpOut (OutputNode outTys [("source", "makeCase")])) for_ (zip (fst <$> outs) (Port outId <$> [0..])) addEdge - addOp (parent, OpCase (ix, Case (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) caseId + setOp caseId (OpCase (ix, Case (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) pure outTys allRowsEqual :: [[HugrType]] -> Bool @@ -857,13 +854,11 @@ compile :: Store -> VEnv -> BS.ByteString compile store ns g capSets venv = - let - (moduleName, ns') = fresh "module" ns - moduleNode = NodeId moduleName + let (moduleNode, initState) = makeCS (g, capSets, ns, store) "module" (OpMod ModuleOp) in evalState (trackM "compileFunctions" *> compileModule venv moduleNode *> trackM "dumpJSON" *> dumpJSON ) - (makeCS (g, capSets, ns', store) moduleNode (OpMod ModuleOp)) + initState diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index f242f75c..c2d4e4f4 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,42 +1,76 @@ {-# LANGUAGE OverloadedStrings #-} -module Data.HugrGraph(Hugr, PortId(..), - newWithRoot, addOp, getParent, getOp, - addEdge, addOrderEdge, edgeList, - serialize +module Data.HugrGraph(Hugr, NodeId, PortId(..), + newWithRoot, splitNamespace, rootNode, + freshNodeWithParent, setOp, getParent, getOp, + addEdge, addOrderEdge, + edgeList, serialize ) where +import Brat.Naming + import Data.Hugr hiding (Hugr) import qualified Data.Hugr as D import Data.List (partition, sortBy) import Data.Maybe (fromMaybe) import Data.Ord (comparing) +import Data.Tuple (swap) import qualified Data.Map as M -data Hugr node = HugrGraph { - -- the values here are (parent, op). +newtype NodeId = NodeId Name deriving (Eq, Ord, Show) + +data Hugr = HugrGraph { -- exactly one node (the root) will have parent == self - nodes :: M.Map node (node, HugrOp), - edges_out :: M.Map node [(Int, PortId node)], - edges_in :: M.Map node [(PortId node, Int)] + parents :: M.Map NodeId NodeId, + nodes :: M.Map NodeId HugrOp, + edges_out :: M.Map NodeId [(Int, PortId NodeId)], + edges_in :: M.Map NodeId [(PortId NodeId, Int)], + nameSupply :: Namespace } deriving (Eq, Show) -- we probably want a better `show` -addOp :: Ord node => Hugr node -> node -> (node, HugrOp) -> Hugr node --- Do not insist the parent exists, we are not there yet -addOp h@HugrGraph {nodes} name weight = - -- alter + partial match is just to fail if key already present - h { nodes = M.alter (\Nothing -> Just weight) name nodes } - -newWithRoot :: node -> HugrOp -> Hugr node -newWithRoot name op = HugrGraph { - nodes = M.singleton name (name, op), - edges_in = M.empty, - edges_out = M.empty -} - -addEdge :: Ord node => Hugr node -> (PortId node, PortId node) -> Hugr node -addEdge HugrGraph {..} (src@(Port s o), tgt@(Port t i)) = case (M.lookup s nodes, M.lookup t nodes) of - (Just _, Just _) -> HugrGraph { - nodes, +-- Quite inefficient on arbitrary Hugr but used only when we know there are few nodes +rootNode :: Hugr -> NodeId +rootNode HugrGraph {parents} = let [root] = [node | (node,parent) <- M.assocs parents, node == parent] + in root + +splitNamespace :: Hugr -> String -> (Namespace, Hugr) +splitNamespace hugr n = let (nsx, nsNew) = split n (nameSupply hugr) + in (nsx, hugr {nameSupply = nsNew}) + +freshNodeWithParent :: Hugr -> NodeId -> String -> (NodeId, Hugr) +freshNodeWithParent hugr@(HugrGraph {parents, nameSupply}) parent nam = + case M.lookup parent parents of + Nothing -> error "parent does not exist" + Just _ -> let (freshName, newSupply) = fresh nam nameSupply + in (NodeId freshName, hugr { + nameSupply = newSupply, + parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents + }) + +setOp :: Hugr -> NodeId -> HugrOp -> Hugr +-- Insist the parent exists +setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of + Nothing -> error "name has no parent" + Just _ -> + -- alter + partial match is just to fail if key already present + h { nodes = M.alter (\Nothing -> Just op) name nodes } + +newWithRoot :: Namespace -> String -> HugrOp -> (Hugr, NodeId) +newWithRoot ns nam op = + let (name, ns') = fresh nam ns + node = NodeId name + in (HugrGraph { + parents = M.singleton node node, + nodes = M.singleton node op, + edges_in = M.empty, + edges_out = M.empty, + nameSupply = ns' + } + ,node + ) + +addEdge :: Hugr -> (PortId NodeId, PortId NodeId) -> Hugr +addEdge h@HugrGraph {..} (src@(Port s o), tgt@(Port t i)) = case (M.lookup s nodes, M.lookup t nodes) of + (Just _, Just _) -> h { edges_out = addToMap s (o, tgt) edges_out, edges_in = addToMap t (src, i) edges_in } @@ -45,32 +79,30 @@ addEdge HugrGraph {..} (src@(Port s o), tgt@(Port t i)) = case (M.lookup s nodes addToMap :: Ord k => k -> v -> M.Map k [v] -> M.Map k [v] addToMap k v m = M.insert k (v:(fromMaybe [] $ M.lookup k m)) m -addOrderEdge :: Ord node => Hugr node -> (node, node) -> Hugr node +addOrderEdge :: Hugr -> (NodeId, NodeId) -> Hugr addOrderEdge h (src, tgt) = addEdge h (Port src orderEdgeOffset, Port tgt orderEdgeOffset) -edgeList :: Hugr node -> [(PortId node, PortId node)] +edgeList :: Hugr -> [(PortId NodeId, PortId NodeId)] edgeList (HugrGraph {edges_out}) = [(Port n off, tgt) | (n, vs) <- M.assocs edges_out , (off, tgt) <- vs ] -getParent :: Ord node => Hugr node -> node -> node -getParent HugrGraph {nodes} n = let (parent, _) = nodes M.! n in parent +getParent :: Hugr -> NodeId -> NodeId +getParent HugrGraph {parents} n = parents M.! n -getOp :: Ord node => Hugr node -> node -> HugrOp -getOp HugrGraph {nodes} n = let (_, op) = nodes M.! n in op +getOp :: Hugr -> NodeId -> HugrOp +getOp HugrGraph {nodes} n = nodes M.! n -serialize :: forall node. Ord node => Hugr node -> D.Hugr Int -serialize hugr@(HugrGraph {nodes}) = D.Hugr ( - [(transNode parent, op) | (parent, op) <- snd <$> sortedNodes], +serialize :: Hugr -> D.Hugr Int +serialize hugr@(HugrGraph {nodes, parents}) = D.Hugr ( + [(transNode parent, op) | (op, parent) <- snd <$> sortedNodes], [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] ) where - sortOrder :: (node, (node, HugrOp)) -> (HugrOp, node, node) - sortOrder (name, (parent, op)) = (op, parent, name) - - sortedNodes :: [(node, (node, HugrOp))] - sortedNodes = let isRoot (name, (parent, _op)) = name == parent - ([root], rest) = partition isRoot (M.assocs nodes) - in (root:(sortBy (comparing sortOrder) rest)) - - transNode :: node -> Int + sortedNodes :: [(NodeId, (HugrOp, NodeId))] -- name, (op, parent) + sortedNodes = let nodesWithParents = [(name, (nodes M.! name, parent)) | (name, parent) <- M.assocs parents] + isRoot (name, (_op, parent)) = name == parent + ([root], rest) = partition isRoot nodesWithParents + in root:(sortBy (comparing swap) rest) + + transNode :: NodeId -> Int transNode = ((M.fromList $ zip (fst <$> sortedNodes) [0..]) M.!) From 33a498c9fcfef1335fbc235eda762c507b3de515 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 10:16:51 +0000 Subject: [PATCH 005/149] WIP inline withIO --- brat/Brat/Compile/Hugr.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 4a1b1785..885b4efd 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -811,20 +811,16 @@ compileModule venv moduleNode = do -- computation that produces this constant. We do so by making a FuncDefn -- that takes no arguments and produces the constant kernel graph value. thunkTy <- HTFunc . PolyFuncType [] . (\(ins, outs) -> FunctionType ins outs bratExts) <$> compileSig Kerny cty - pure (funcReturning [thunkTy], True, \parent -> - withIO parent thunkTy $ compileKernBox parent input (compileBox (src, tgt)) cty) + pure (funcReturning [thunkTy], True, \parent -> do + addNode "input" (parent, OpIn (InputNode [] [("source", "analyseDecl")])) + output <- addNode "output" (parent, OpOut (OutputNode [thunkTy] [("source", "analyseDecl")])) + wire <- compileKernBox parent input (compileBox (src, tgt)) cty + addEdge (fst wire, Port output 0)) _ -> error "Box should have exactly one output of Thunk type" _ -> do -- a computation, or several values outs <- compilePorts srcPortTys -- note compiling already-erased types, is this right? pure (funcReturning outs, True, compileNoun outs (map fst srcPortTys)) - withIO :: NodeId -> HugrType -> Compile TypedPort -> Compile () - withIO parent output c = do - addNode "input" (parent, OpIn (InputNode [] [("source", "analyseDecl")])) - output <- addNode "output" (parent, OpOut (OutputNode [output] [("source", "analyseDecl")])) - wire <- c - addEdge (fst wire, Port output 0) - -- top-level decls that are not Prims. RHS is the brat idNode decls :: [(QualName, Name)] decls = do -- in list monad, no Compile here From 99a7416b6c8a6bc56e6968c0f83a3f6df52b9334 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 12:59:14 +0000 Subject: [PATCH 006/149] refactor: lift compileNode up to top level --- brat/Brat/Compile/Hugr.hs | 93 ++++++++++++++++++++------------------- 1 file changed, 48 insertions(+), 45 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 885b4efd..efc35578 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -275,60 +275,63 @@ compileBox :: (Name, Name) -> NodeId -> Compile () -- note: we used to compile only KernelNode's here, this may not be right compileBox (src, tgt) parent = for_ [src, tgt] (compileWithInputs parent) +in_edges :: Name -> Compile [((OutPort, Val Z), Int)] +in_edges name = gets bratGraph <&> \(_, es) -> [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name] + + compileWithInputs :: NodeId -> Name -> Compile (Maybe NodeId) compileWithInputs parent name = gets compiled >>= (\case Just nid -> pure (Just nid) Nothing -> do - (_, es) <- gets bratGraph - let in_edges = [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name] - compileNode in_edges >>= \case + compileNode parent name >>= \case Nothing -> pure Nothing Just (tgtNodeId, edges) -> do registerCompiled name tgtNodeId for_ edges (\(src, tgtPort) -> addEdge (src, Port tgtNodeId tgtPort)) pure $ Just tgtNodeId) . M.lookup name - where - -- If we only care about the node for typechecking, then drop it and return `Nothing`. - -- Otherwise, NodeId of compiled node, and list of Hugr in-edges (source and target-port) - compileNode :: [((OutPort, Val Z), Int)] -> Compile (Maybe (NodeId, [(PortId NodeId, Int)])) - compileNode in_edges | isJust (hasPrefix ["checking", "globals", "decl"] name) = do - -- reference to a top-level decl. Every such should be in the decls map. - -- We need to return value of each type (perhaps to be indirectCalled by successor). - -- Note this is where we must compile something different *for each caller* by clearing out the `compiled` map for each function - let hTys = map (compileType . snd . fst) $ sortBy (comparing snd) in_edges - - decls <- gets decls - let (funcDef, extra_call) = decls M.! name - nod <- if extra_call - then addNode ("direct_call(" ++ show funcDef ++ ")") - (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) - -- We are loading idNode as a value (not an Eval'd thing), and it is a FuncDef directly - -- corresponding to a Brat TLD (not that produces said TLD when eval'd) - else case hTys of - [HTFunc poly@(PolyFuncType [] _)] -> - addNode ("load_thunk(" ++ show funcDef ++ ")") - (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) - [HTFunc (PolyFuncType args _)] -> error $ unwords ["Unexpected type args to" - ,show funcDef ++ ":" - ,show args - ] - _ -> error $ "Expected a function argument when loading thunk, got: " ++ show hTys - -- the only input - pure $ Just (nod, [(Port funcDef 0, 0)]) - compileNode in_edges = do - (ns, _) <- gets bratGraph - let node = ns M.! name - trackM ("compileNode (" ++ show parent ++ ") " ++ show name ++ " " ++ show node) - nod_edge_info <- case node of - (BratNode thing ins outs) -> compileNode' thing ins outs - (KernelNode thing ins outs) -> compileNode' thing ins outs - case nod_edge_info of - Nothing -> pure Nothing - Just (node, tgtOffset, extra_edges) -> do - trans_edges <- catMaybes <$> for in_edges (\((src, _), tgtPort) -> - getOutPort parent src <&> fmap (, tgtPort + tgtOffset)) - pure $ Just (node, extra_edges ++ trans_edges) +-- If we only care about the node for typechecking, then drop it and return `Nothing`. +-- Otherwise, NodeId of compiled node, and list of Hugr in-edges (source and target-port) +compileNode :: NodeId -> Name -> Compile (Maybe (NodeId, [(PortId NodeId, Int)])) +compileNode parent name | isJust (hasPrefix ["checking", "globals", "decl"] name) = do + -- reference to a top-level decl. Every such should be in the decls map. + -- We need to return value of each type (perhaps to be indirectCalled by successor). + -- Note this is where we must compile something different *for each caller* by clearing out the `compiled` map for each function + hTys <- in_edges name <&> (map (compileType . snd . fst) . sortBy (comparing snd)) + + decls <- gets decls + let (funcDef, extra_call) = decls M.! name + nod <- if extra_call + then addNode ("direct_call(" ++ show funcDef ++ ")") + (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) + -- We are loading idNode as a value (not an Eval'd thing), and it is a FuncDef directly + -- corresponding to a Brat TLD (not that produces said TLD when eval'd) + else case hTys of + [HTFunc poly@(PolyFuncType [] _)] -> + addNode ("load_thunk(" ++ show funcDef ++ ")") + (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) + [HTFunc (PolyFuncType args _)] -> error $ unwords ["Unexpected type args to" + ,show funcDef ++ ":" + ,show args + ] + _ -> error $ "Expected a function argument when loading thunk, got: " ++ show hTys + -- the only input + pure $ Just (nod, [(Port funcDef 0, 0)]) +compileNode parent name = do + (ns, _) <- gets bratGraph + let node = ns M.! name + trackM ("compileNode (" ++ show parent ++ ") " ++ show name ++ " " ++ show node) + nod_edge_info <- case node of + (BratNode thing ins outs) -> compileNode' thing ins outs + (KernelNode thing ins outs) -> compileNode' thing ins outs + case nod_edge_info of + Nothing -> pure Nothing + Just (node, tgtOffset, extra_edges) -> do + in_edges <- in_edges name + trans_edges <- catMaybes <$> for in_edges (\((src, _), tgtPort) -> + getOutPort parent src <&> fmap (, tgtPort + tgtOffset)) + pure $ Just (node, extra_edges ++ trans_edges) + where default_edges :: NodeId -> Maybe (NodeId, Int, [(PortId NodeId, Int)]) default_edges nid = Just (nid, 0, []) @@ -346,7 +349,7 @@ compileWithInputs parent name = gets compiled >>= (\case Just suffix -> do (ns, _) <- gets bratGraph case M.lookup outNode ns of - Just (BratNode (Prim (ext,op)) _ [(_, VFun Kerny _)]) -> do + Just (BratNode (Prim (ext,op)) _ [(_, VFun Kerny _)]) -> addNode (show suffix) (parent, OpCustom (CustomOp ext op sig [])) x -> error $ "Expected a Prim kernel node but got " ++ show x -- All other evaled things are turned into holes to be substituted later From 5ec4c6753e5db40f4de1ff7725a6bedfaf929a5e Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 16:20:05 +0000 Subject: [PATCH 007/149] Revert "refactor: lift compileNode up to top level" This reverts commit 99a7416b6c8a6bc56e6968c0f83a3f6df52b9334. --- brat/Brat/Compile/Hugr.hs | 93 +++++++++++++++++++-------------------- 1 file changed, 45 insertions(+), 48 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index efc35578..885b4efd 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -275,63 +275,60 @@ compileBox :: (Name, Name) -> NodeId -> Compile () -- note: we used to compile only KernelNode's here, this may not be right compileBox (src, tgt) parent = for_ [src, tgt] (compileWithInputs parent) -in_edges :: Name -> Compile [((OutPort, Val Z), Int)] -in_edges name = gets bratGraph <&> \(_, es) -> [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name] - - compileWithInputs :: NodeId -> Name -> Compile (Maybe NodeId) compileWithInputs parent name = gets compiled >>= (\case Just nid -> pure (Just nid) Nothing -> do - compileNode parent name >>= \case + (_, es) <- gets bratGraph + let in_edges = [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name] + compileNode in_edges >>= \case Nothing -> pure Nothing Just (tgtNodeId, edges) -> do registerCompiled name tgtNodeId for_ edges (\(src, tgtPort) -> addEdge (src, Port tgtNodeId tgtPort)) pure $ Just tgtNodeId) . M.lookup name - --- If we only care about the node for typechecking, then drop it and return `Nothing`. --- Otherwise, NodeId of compiled node, and list of Hugr in-edges (source and target-port) -compileNode :: NodeId -> Name -> Compile (Maybe (NodeId, [(PortId NodeId, Int)])) -compileNode parent name | isJust (hasPrefix ["checking", "globals", "decl"] name) = do - -- reference to a top-level decl. Every such should be in the decls map. - -- We need to return value of each type (perhaps to be indirectCalled by successor). - -- Note this is where we must compile something different *for each caller* by clearing out the `compiled` map for each function - hTys <- in_edges name <&> (map (compileType . snd . fst) . sortBy (comparing snd)) - - decls <- gets decls - let (funcDef, extra_call) = decls M.! name - nod <- if extra_call - then addNode ("direct_call(" ++ show funcDef ++ ")") - (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) - -- We are loading idNode as a value (not an Eval'd thing), and it is a FuncDef directly - -- corresponding to a Brat TLD (not that produces said TLD when eval'd) - else case hTys of - [HTFunc poly@(PolyFuncType [] _)] -> - addNode ("load_thunk(" ++ show funcDef ++ ")") - (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) - [HTFunc (PolyFuncType args _)] -> error $ unwords ["Unexpected type args to" - ,show funcDef ++ ":" - ,show args - ] - _ -> error $ "Expected a function argument when loading thunk, got: " ++ show hTys - -- the only input - pure $ Just (nod, [(Port funcDef 0, 0)]) -compileNode parent name = do - (ns, _) <- gets bratGraph - let node = ns M.! name - trackM ("compileNode (" ++ show parent ++ ") " ++ show name ++ " " ++ show node) - nod_edge_info <- case node of - (BratNode thing ins outs) -> compileNode' thing ins outs - (KernelNode thing ins outs) -> compileNode' thing ins outs - case nod_edge_info of - Nothing -> pure Nothing - Just (node, tgtOffset, extra_edges) -> do - in_edges <- in_edges name - trans_edges <- catMaybes <$> for in_edges (\((src, _), tgtPort) -> - getOutPort parent src <&> fmap (, tgtPort + tgtOffset)) - pure $ Just (node, extra_edges ++ trans_edges) where + -- If we only care about the node for typechecking, then drop it and return `Nothing`. + -- Otherwise, NodeId of compiled node, and list of Hugr in-edges (source and target-port) + compileNode :: [((OutPort, Val Z), Int)] -> Compile (Maybe (NodeId, [(PortId NodeId, Int)])) + compileNode in_edges | isJust (hasPrefix ["checking", "globals", "decl"] name) = do + -- reference to a top-level decl. Every such should be in the decls map. + -- We need to return value of each type (perhaps to be indirectCalled by successor). + -- Note this is where we must compile something different *for each caller* by clearing out the `compiled` map for each function + let hTys = map (compileType . snd . fst) $ sortBy (comparing snd) in_edges + + decls <- gets decls + let (funcDef, extra_call) = decls M.! name + nod <- if extra_call + then addNode ("direct_call(" ++ show funcDef ++ ")") + (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) + -- We are loading idNode as a value (not an Eval'd thing), and it is a FuncDef directly + -- corresponding to a Brat TLD (not that produces said TLD when eval'd) + else case hTys of + [HTFunc poly@(PolyFuncType [] _)] -> + addNode ("load_thunk(" ++ show funcDef ++ ")") + (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) + [HTFunc (PolyFuncType args _)] -> error $ unwords ["Unexpected type args to" + ,show funcDef ++ ":" + ,show args + ] + _ -> error $ "Expected a function argument when loading thunk, got: " ++ show hTys + -- the only input + pure $ Just (nod, [(Port funcDef 0, 0)]) + compileNode in_edges = do + (ns, _) <- gets bratGraph + let node = ns M.! name + trackM ("compileNode (" ++ show parent ++ ") " ++ show name ++ " " ++ show node) + nod_edge_info <- case node of + (BratNode thing ins outs) -> compileNode' thing ins outs + (KernelNode thing ins outs) -> compileNode' thing ins outs + case nod_edge_info of + Nothing -> pure Nothing + Just (node, tgtOffset, extra_edges) -> do + trans_edges <- catMaybes <$> for in_edges (\((src, _), tgtPort) -> + getOutPort parent src <&> fmap (, tgtPort + tgtOffset)) + pure $ Just (node, extra_edges ++ trans_edges) + default_edges :: NodeId -> Maybe (NodeId, Int, [(PortId NodeId, Int)]) default_edges nid = Just (nid, 0, []) @@ -349,7 +346,7 @@ compileNode parent name = do Just suffix -> do (ns, _) <- gets bratGraph case M.lookup outNode ns of - Just (BratNode (Prim (ext,op)) _ [(_, VFun Kerny _)]) -> + Just (BratNode (Prim (ext,op)) _ [(_, VFun Kerny _)]) -> do addNode (show suffix) (parent, OpCustom (CustomOp ext op sig [])) x -> error $ "Expected a Prim kernel node but got " ++ show x -- All other evaled things are turned into holes to be substituted later From b9be70d5d395aed8a26e12479a906540d4960c48 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 10:58:54 +0000 Subject: [PATCH 008/149] Separate out compilation of Source - fails 3 tests --- brat/Brat/Compile/Hugr.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 885b4efd..b098ea13 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -167,7 +167,8 @@ registerCompiled :: Name -> NodeId -> Compile () registerCompiled from to | track (show from ++ " |-> " ++ show to) False = undefined registerCompiled from to = do st <- get - put (st { compiled = M.insert from to (compiled st) }) + let new_compiled = M.alter (\Nothing -> Just to) from (compiled st) + put (st { compiled = new_compiled }) compileConst :: NodeId -> SimpleTerm -> HugrType -> Compile NodeId compileConst parent tm ty = do @@ -273,10 +274,21 @@ compileClauses parent ins ((matchData, rhs) :| clauses) = do compileBox :: (Name, Name) -> NodeId -> Compile () -- note: we used to compile only KernelNode's here, this may not be right -compileBox (src, tgt) parent = for_ [src, tgt] (compileWithInputs parent) +compileBox (src, tgt) parent = do + (ns, _) <- gets bratGraph + let node = ns M.! src + trackM ("compileSource (" ++ show parent ++ ") " ++ show src ++ " " ++ show node) + let outs = case node of + (BratNode Source [] outs) -> outs + (KernelNode Source [] outs) -> outs + outs <- compilePorts outs + srcNode <- addNode "Input" (parent, OpIn (InputNode outs [("source", "Source"), ("parent", show parent)])) + registerCompiled src srcNode + compileWithInputs parent tgt + pure () compileWithInputs :: NodeId -> Name -> Compile (Maybe NodeId) -compileWithInputs parent name = gets compiled >>= (\case +compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case Just nid -> pure (Just nid) Nothing -> do (_, es) <- gets bratGraph @@ -286,7 +298,7 @@ compileWithInputs parent name = gets compiled >>= (\case Just (tgtNodeId, edges) -> do registerCompiled name tgtNodeId for_ edges (\(src, tgtPort) -> addEdge (src, Port tgtNodeId tgtPort)) - pure $ Just tgtNodeId) . M.lookup name + pure $ Just tgtNodeId where -- If we only care about the node for typechecking, then drop it and return `Nothing`. -- Otherwise, NodeId of compiled node, and list of Hugr in-edges (source and target-port) @@ -419,9 +431,8 @@ compileWithInputs parent name = gets compiled >>= (\case pure $ Just (partialNode, 1, captures) -- 1 is arbitrary, Box has no real inputs outs -> error $ "Unexpected outs of box: " ++ show outs - Source -> default_edges <$> do - outs <- compilePorts outs - addNode "Input" (parent, OpIn (InputNode outs [("source", "Source"), ("parent", show parent)])) + Source -> error "Source found outside of compileBox" + Target -> default_edges <$> do ins <- compilePorts ins addNode "Output" (parent, OpOut (OutputNode ins [("source", "Target")])) From 4f3d1ffed20c40c498140da9fe70ea151a0fef5b Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 14:44:10 +0000 Subject: [PATCH 009/149] Fix Eval not respecting liftedOutPorts -> just 1 fail --- brat/Brat/Compile/Hugr.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index b098ea13..5b0b2bd9 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -388,7 +388,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case pure $ default_edges loadConst -- Check if the node has prefix "globals", hence should be a direct call - Eval (Ex outNode outPort) -> do + Eval tgt@(Ex outNode _) -> do ins <- compilePorts ins outs <- compilePorts outs (ns, _) <- gets bratGraph @@ -412,13 +412,13 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case -- Either not global, or we must evaluate the global -- so an indirect call of a graph on a wire -- (If it's a global, compileWithInputs will generate extra no-args Call, -- since extra_call==True; we just turned the (Eval+)LoadFunction case into a direct Call above) - _ -> compileWithInputs parent outNode >>= \case - Just calleeId -> do + _ -> getOutPort parent tgt >>= \case + Just funcPort@(Port calleeId _) -> do callerId <- addNode ("indirect_call(" ++ show calleeId ++ ")") (parent, OpCallIndirect (CallIndirectOp (FunctionType ins outs bratExts {-[]-}))) -- for an IndirectCall, the callee (thunk, function value) is the *first* -- Hugr input. So move all the others along, and add that extra edge. - pure $ Just (callerId, 1, [(Port calleeId outPort, 0)]) + pure $ Just (callerId, 1, [(funcPort, 0)]) Nothing -> error "Callee has been erased" -- We need to figure out if this thunk contains a brat- or a kernel-computation @@ -451,7 +451,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case PatternMatch cs -> default_edges <$> do ins <- compilePorts ins outs <- compilePorts outs - dfgId <- addNode "DidMatch_DFG" (parent, OpDFG (DFG (FunctionType ins outs bratExts) [])) + dfgId <- addNode "PatternMatch_DFG" (parent, OpDFG (DFG (FunctionType ins outs bratExts) [])) inputNode <- addNode "PatternMatch.Input" (dfgId, OpIn (InputNode ins [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts <- compileClauses dfgId (zip (Port inputNode <$> [0..]) ins) cs addNodeWithInputs "PatternMatch.Output" (dfgId, OpOut (OutputNode (snd <$> ccOuts) [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts [] From 5e4ee498b27f9af9c103267afea16824fb3e444f Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 14:57:34 +0000 Subject: [PATCH 010/149] And splices should use getOutPort too --- brat/Brat/Compile/Hugr.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 5b0b2bd9..bd49f744 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -566,11 +566,11 @@ compileKernBox parent name contents cty = do -- compile the kernel that should be spliced in and record its signature. ns <- gets (fst . bratGraph) hole_ports <- for (holelist <>> []) (\splice -> do - let (KernelNode (Splice (Ex kernel_src port)) ins outs) = ns M.! splice + let (KernelNode (Splice kernel_src) ins outs) = ns M.! splice ins <- compilePorts ins outs <- compilePorts outs - kernel_src <- compileWithInputs parent kernel_src <&> fromJust - pure (Port kernel_src port, HTFunc (PolyFuncType [] (FunctionType ins outs bratExts)))) + kernel_src <- getOutPort parent kernel_src <&> fromJust + pure (kernel_src, HTFunc (PolyFuncType [] (FunctionType ins outs bratExts)))) -- Add a substitute node to fill the holes in the template let hole_sigs = [ body poly | (_, HTFunc poly) <- hole_ports ] From af49caff80bb75b716e063bdc98481ba5fe2fdf0 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 16:33:11 +0000 Subject: [PATCH 011/149] xfail remaining failure in closures.brat --- brat/test/Test/Compile/Hugr.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 0f3d7bd9..2527d746 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -18,7 +18,7 @@ outputDir = prefix "output" -- examples that we expect to compile, but then to fail validation invalidExamples :: [FilePath] -invalidExamples = map ((++ ".brat") . ("examples" )) +invalidExamples = (map ((++ ".brat") . ("examples" )) ["adder" ,"app" ,"dollar_kind" @@ -29,6 +29,7 @@ invalidExamples = map ((++ ".brat") . ("examples" )) ,"infer_thunks2" -- Weird: Mismatch between caller and callee signatures in map call ,"repeated_app" -- missing coercions, https://github.com/quantinuum-dev/brat/issues/413 ,"thunks"] + ) ++ ["test/compilation/closures.brat"] -- fails to compile but still spits out some JSON (not whole Hugr) -- examples that we expect not to compile. -- Note this does not include those with remaining holes; these are automatically skipped. @@ -57,6 +58,10 @@ nonCompilingExamples = expectedCheckingFails ++ expectedParsingFails ++ ,"vlup_covering" ] +-- this one seems to generate a Brat Graph containing three Box nodes with different Sources, +-- but the same Target, which reads from all three +nonCompilingTests = ["test/compilation/closures.brat"] + compileToOutput :: FilePath -> TestTree compileToOutput file = testCaseInfo (show file) $ compileFile [] file >>= \case Right bs -> do @@ -71,7 +76,7 @@ setupCompilationTests = do tests <- findByExtension [".brat"] prefix examples <- findByExtension [".brat"] examplesPrefix createDirectoryIfMissing False outputDir - let compileTests = compileToOutput <$> tests + let compileTests = expectFailForPaths nonCompilingTests compileToOutput tests let examplesTests = testGroup "examples" $ expectFailForPaths nonCompilingExamples compileToOutput examples pure $ testGroup "compilation" (examplesTests:compileTests) From 8b74892c499e508990548dd10629afd83fb06f0d Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 17:22:43 +0000 Subject: [PATCH 012/149] fixup! Separate out --- brat/Brat/Compile/Hugr.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index bd49f744..9d16cfc4 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -276,13 +276,14 @@ compileBox :: (Name, Name) -> NodeId -> Compile () -- note: we used to compile only KernelNode's here, this may not be right compileBox (src, tgt) parent = do (ns, _) <- gets bratGraph + -- Compile Source let node = ns M.! src trackM ("compileSource (" ++ show parent ++ ") " ++ show src ++ " " ++ show node) - let outs = case node of + let src_outs = case node of (BratNode Source [] outs) -> outs (KernelNode Source [] outs) -> outs - outs <- compilePorts outs - srcNode <- addNode "Input" (parent, OpIn (InputNode outs [("source", "Source"), ("parent", show parent)])) + srcTys <- compilePorts src_outs + srcNode <- addNode "Input" (parent, OpIn (InputNode srcTys [("source", "Source"), ("parent", show parent)])) registerCompiled src srcNode compileWithInputs parent tgt pure () From 1e9e1f2dc1bfe3b3045f84f0b56f1e3abefcd16e Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 17:22:54 +0000 Subject: [PATCH 013/149] refactor out compileInEdges --- brat/Brat/Compile/Hugr.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 9d16cfc4..0548c4f1 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -288,6 +288,10 @@ compileBox (src, tgt) parent = do compileWithInputs parent tgt pure () +compileInEdges :: NodeId -> [((OutPort, Val Z), p)] -> Compile [(PortId NodeId, p)] +compileInEdges parent in_edges = catMaybes <$> for in_edges ( + \((src, _), tgtPort) -> getOutPort parent src <&> fmap (, tgtPort)) + compileWithInputs :: NodeId -> Name -> Compile (Maybe NodeId) compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case Just nid -> pure (Just nid) @@ -338,8 +342,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case case nod_edge_info of Nothing -> pure Nothing Just (node, tgtOffset, extra_edges) -> do - trans_edges <- catMaybes <$> for in_edges (\((src, _), tgtPort) -> - getOutPort parent src <&> fmap (, tgtPort + tgtOffset)) + trans_edges <- compileInEdges parent in_edges <&> map (second (+tgtOffset)) pure $ Just (node, extra_edges ++ trans_edges) default_edges :: NodeId -> Maybe (NodeId, Int, [(PortId NodeId, Int)]) From 33eb452b3416802f689b5fc6e56537da8f8d8be6 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 17:34:16 +0000 Subject: [PATCH 014/149] refactor in_edges to top-level --- brat/Brat/Compile/Hugr.hs | 91 ++++++++++++++++++++------------------- 1 file changed, 47 insertions(+), 44 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 0548c4f1..e99ef87b 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -36,7 +36,7 @@ import Data.Foldable (traverse_, for_) import Data.Functor ((<&>), ($>)) import Data.List (sortBy) import qualified Data.Map as M -import Data.Maybe (catMaybes, fromJust, isJust) +import Data.Maybe (catMaybes, fromJust) import Data.Ord (comparing) import Data.Traversable (for) import Control.Monad.State @@ -288,17 +288,19 @@ compileBox (src, tgt) parent = do compileWithInputs parent tgt pure () -compileInEdges :: NodeId -> [((OutPort, Val Z), p)] -> Compile [(PortId NodeId, p)] -compileInEdges parent in_edges = catMaybes <$> for in_edges ( - \((src, _), tgtPort) -> getOutPort parent src <&> fmap (, tgtPort)) +in_edges :: Name -> Compile [((OutPort, Val Z), Int)] +in_edges name = gets bratGraph <&> \(_, es) -> [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name] + +compileInEdges :: NodeId -> Name -> Compile [(PortId NodeId, Int)] +compileInEdges parent name = do + in_edges <- in_edges name + catMaybes <$> for in_edges (\((src, _), tgtPort) -> getOutPort parent src <&> fmap (, tgtPort)) compileWithInputs :: NodeId -> Name -> Compile (Maybe NodeId) compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case Just nid -> pure (Just nid) Nothing -> do - (_, es) <- gets bratGraph - let in_edges = [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name] - compileNode in_edges >>= \case + compileNode >>= \case Nothing -> pure Nothing Just (tgtNodeId, edges) -> do registerCompiled name tgtNodeId @@ -307,43 +309,44 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case where -- If we only care about the node for typechecking, then drop it and return `Nothing`. -- Otherwise, NodeId of compiled node, and list of Hugr in-edges (source and target-port) - compileNode :: [((OutPort, Val Z), Int)] -> Compile (Maybe (NodeId, [(PortId NodeId, Int)])) - compileNode in_edges | isJust (hasPrefix ["checking", "globals", "decl"] name) = do - -- reference to a top-level decl. Every such should be in the decls map. - -- We need to return value of each type (perhaps to be indirectCalled by successor). - -- Note this is where we must compile something different *for each caller* by clearing out the `compiled` map for each function - let hTys = map (compileType . snd . fst) $ sortBy (comparing snd) in_edges - - decls <- gets decls - let (funcDef, extra_call) = decls M.! name - nod <- if extra_call - then addNode ("direct_call(" ++ show funcDef ++ ")") - (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) - -- We are loading idNode as a value (not an Eval'd thing), and it is a FuncDef directly - -- corresponding to a Brat TLD (not that produces said TLD when eval'd) - else case hTys of - [HTFunc poly@(PolyFuncType [] _)] -> - addNode ("load_thunk(" ++ show funcDef ++ ")") - (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) - [HTFunc (PolyFuncType args _)] -> error $ unwords ["Unexpected type args to" - ,show funcDef ++ ":" - ,show args - ] - _ -> error $ "Expected a function argument when loading thunk, got: " ++ show hTys - -- the only input - pure $ Just (nod, [(Port funcDef 0, 0)]) - compileNode in_edges = do - (ns, _) <- gets bratGraph - let node = ns M.! name - trackM ("compileNode (" ++ show parent ++ ") " ++ show name ++ " " ++ show node) - nod_edge_info <- case node of - (BratNode thing ins outs) -> compileNode' thing ins outs - (KernelNode thing ins outs) -> compileNode' thing ins outs - case nod_edge_info of - Nothing -> pure Nothing - Just (node, tgtOffset, extra_edges) -> do - trans_edges <- compileInEdges parent in_edges <&> map (second (+tgtOffset)) - pure $ Just (node, extra_edges ++ trans_edges) + compileNode :: Compile (Maybe (NodeId, [(PortId NodeId, Int)])) + compileNode = case (hasPrefix ["checking", "globals", "decl"] name) of + Just _ -> do + -- reference to a top-level decl. Every such should be in the decls map. + -- We need to return value of each type (perhaps to be indirectCalled by successor). + -- Note this is where we must compile something different *for each caller* by clearing out the `compiled` map for each function + hTys <- in_edges name <&> (map (compileType . snd . fst) . sortBy (comparing snd)) + + decls <- gets decls + let (funcDef, extra_call) = decls M.! name + nod <- if extra_call + then addNode ("direct_call(" ++ show funcDef ++ ")") + (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) + -- We are loading idNode as a value (not an Eval'd thing), and it is a FuncDef directly + -- corresponding to a Brat TLD (not that produces said TLD when eval'd) + else case hTys of + [HTFunc poly@(PolyFuncType [] _)] -> + addNode ("load_thunk(" ++ show funcDef ++ ")") + (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) + [HTFunc (PolyFuncType args _)] -> error $ unwords ["Unexpected type args to" + ,show funcDef ++ ":" + ,show args + ] + _ -> error $ "Expected a function argument when loading thunk, got: " ++ show hTys + -- the only input + pure $ Just (nod, [(Port funcDef 0, 0)]) + _ -> do + (ns, _) <- gets bratGraph + let node = ns M.! name + trackM ("compileNode (" ++ show parent ++ ") " ++ show name ++ " " ++ show node) + nod_edge_info <- case node of + (BratNode thing ins outs) -> compileNode' thing ins outs + (KernelNode thing ins outs) -> compileNode' thing ins outs + case nod_edge_info of + Nothing -> pure Nothing + Just (node, tgtOffset, extra_edges) -> do + trans_edges <- compileInEdges parent name <&> map (second (+tgtOffset)) + pure $ Just (node, extra_edges ++ trans_edges) default_edges :: NodeId -> Maybe (NodeId, Int, [(PortId NodeId, Int)]) default_edges nid = Just (nid, 0, []) From d42778dac552a20f9aefc2f1f0c5ba36390023cf Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 17:43:41 +0000 Subject: [PATCH 015/149] Separate out compilation of Target --- brat/Brat/Compile/Hugr.hs | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index e99ef87b..c4d65d9b 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -275,9 +275,8 @@ compileClauses parent ins ((matchData, rhs) :| clauses) = do compileBox :: (Name, Name) -> NodeId -> Compile () -- note: we used to compile only KernelNode's here, this may not be right compileBox (src, tgt) parent = do - (ns, _) <- gets bratGraph -- Compile Source - let node = ns M.! src + node <- gets ((M.! src) . fst . bratGraph) trackM ("compileSource (" ++ show parent ++ ") " ++ show src ++ " " ++ show node) let src_outs = case node of (BratNode Source [] outs) -> outs @@ -285,7 +284,20 @@ compileBox (src, tgt) parent = do srcTys <- compilePorts src_outs srcNode <- addNode "Input" (parent, OpIn (InputNode srcTys [("source", "Source"), ("parent", show parent)])) registerCompiled src srcNode - compileWithInputs parent tgt + compileTarget parent tgt + +compileTarget :: NodeId -> Name -> Compile () +compileTarget parent tgt = do + node <- gets ((M.! tgt) . fst . bratGraph) + trackM ("compileTarget (" ++ show parent ++ ") " ++ show tgt ++ " " ++ show node) + let tgt_ins = case node of + (BratNode Target ins []) -> ins + (KernelNode Target ins []) -> ins + tgtTys <- compilePorts tgt_ins + tgtNode <- addNode "Output" (parent, OpOut (OutputNode tgtTys [("source", "Target")])) + edges <- compileInEdges parent tgt + -- registerCompiled tgt tgtNode -- really shouldn't be necessary, not reachable + for_ edges (\(src, tgtPort) -> addEdge (src, Port tgtNode tgtPort)) pure () in_edges :: Name -> Compile [((OutPort, Val Z), Int)] @@ -440,9 +452,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case Source -> error "Source found outside of compileBox" - Target -> default_edges <$> do - ins <- compilePorts ins - addNode "Output" (parent, OpOut (OutputNode ins [("source", "Target")])) + Target -> error "Target found outside of compileBox" Id | Nothing <- hasPrefix ["checking", "globals", "decl"] name -> default_edges <$> do -- not a top-level decl, just compile it as an Id (TLDs handled in compileNode) @@ -549,7 +559,7 @@ compileBratBox parent name (venv, src, tgt) cty = do st <- get put $ st {liftedOutPorts = M.fromList lifted} -- no need to return any holes - compileWithInputs dfgId tgt + compileTarget dfgId tgt -- Finally, we add a `Partial` node to supply the captured params. partialNode <- addNode "Partial" (parent, OpCustom $ partialOp boxInnerSig (length params)) From 57c2df778835fa272885d4ad3a8ce2cc48028ea5 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 18:18:41 +0000 Subject: [PATCH 016/149] refactor: compileKernBox takes src+tgt (Name, Name) --- brat/Brat/Compile/Hugr.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index c4d65d9b..451ca3f3 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -443,7 +443,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case -- We need to figure out if this thunk contains a brat- or a kernel-computation (Box src tgt) -> case outs of [(_, VFun Kerny cty)] -> default_edges . nodeId . fst <$> - compileKernBox parent name (compileBox (src, tgt)) cty + compileKernBox parent (show name) (src, tgt) cty [(_, VFun Braty cty)] -> do cs <- gets (M.findWithDefault M.empty name . capSets) (partialNode, captures) <- compileBratBox parent name (cs, src, tgt) cty @@ -568,15 +568,15 @@ compileBratBox parent name (venv, src, tgt) cty = do pure (partialNode, zip (map fromJust edge_srcs) [1..]) -- error on Nothing, the Partial is expecting a value -compileKernBox :: NodeId -> Name -> (NodeId -> Compile ()) -> CTy Kernel Z -> Compile TypedPort -compileKernBox parent name contents cty = do +compileKernBox :: NodeId -> String -> (Name, Name) -> CTy Kernel Z -> Compile TypedPort +compileKernBox parent desc src_tgt cty = do -- compile kernel nodes only into a Hugr with "Holes" -- when we see a Splice, we'll record the func-port onto a list -- return a Hugr with holes boxInnerSig@(inTys, outTys) <- compileSig Kerny cty let boxTy = HTFunc $ PolyFuncType [] (FunctionType inTys outTys bratExts) - (templatePort, holelist) <- compileConstDfg parent ("KB" ++ show name) boxInnerSig $ \dfg_id -> do - contents dfg_id + (templatePort, holelist) <- compileConstDfg parent ("KB" ++ desc) boxInnerSig $ \dfg_id -> do + compileBox src_tgt dfg_id gets holes -- For each hole in the template (index 0 i.e. earliest, first) @@ -591,7 +591,7 @@ compileKernBox parent name contents cty = do -- Add a substitute node to fill the holes in the template let hole_sigs = [ body poly | (_, HTFunc poly) <- hole_ports ] - head <$> addNodeWithInputs ("subst_" ++ show name) (parent, OpCustom (substOp (FunctionType inTys outTys bratExts) hole_sigs)) (templatePort : hole_ports) [boxTy] + head <$> addNodeWithInputs ("subst_" ++ desc) (parent, OpCustom (substOp (FunctionType inTys outTys bratExts) hole_sigs)) (templatePort : hole_ports) [boxTy] -- We get a bunch of TypedPorts which are associated with Srcs in the BRAT graph. @@ -842,7 +842,7 @@ compileModule venv moduleNode = do pure (funcReturning [thunkTy], True, \parent -> do addNode "input" (parent, OpIn (InputNode [] [("source", "analyseDecl")])) output <- addNode "output" (parent, OpOut (OutputNode [thunkTy] [("source", "analyseDecl")])) - wire <- compileKernBox parent input (compileBox (src, tgt)) cty + wire <- compileKernBox parent (show input) (src, tgt) cty addEdge (fst wire, Port output 0)) _ -> error "Box should have exactly one output of Thunk type" _ -> do -- a computation, or several values From 41b913f185d1e3cae1530176551586eae5503597 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 17 Dec 2025 22:52:29 +0000 Subject: [PATCH 017/149] Rename: freshNodeWithParent -> freshNode --- brat/Brat/Compile/Hugr.hs | 12 ++++++------ brat/Data/HugrGraph.hs | 6 +++--- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 451ca3f3..9a2eba7f 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -90,10 +90,10 @@ registerFuncDef name hugrDef = do st <- get put (st { decls = M.insert name hugrDef (decls st) }) -freshNodeWithParent :: String -> NodeId -> Compile NodeId -freshNodeWithParent name parent = do +freshNode :: String -> NodeId -> Compile NodeId +freshNode name parent = do s <- get - let (id, h) = H.freshNodeWithParent (hugr s) parent name + let (id, h) = H.freshNode (hugr s) parent name put s {hugr = h} pure id @@ -102,7 +102,7 @@ addEdge e = get >>= \st -> put (st { hugr = H.addEdge (hugr st) e }) addNode :: String -> (NodeId, HugrOp) -> Compile NodeId addNode nam (parent, op) = do - name <- freshNodeWithParent nam parent + name <- freshNode nam parent setOp name (addMetadata [("id", show name)] op) pure name @@ -716,7 +716,7 @@ makeConditional :: String -- Label -> [(String, NodeId -> [TypedPort] -> Compile [TypedPort])] -- Must be ordered -> Compile [TypedPort] makeConditional lbl parent discrim otherInputs cases = do - condId <- freshNodeWithParent "Conditional" parent + condId <- freshNode "Conditional" parent let rows = getSumVariants (snd discrim) outTyss <- for (zip (zip [0..] cases) rows) (\((ix, (name, f)), row) -> makeCase condId name ix (row ++ (snd <$> otherInputs)) f) unless @@ -730,7 +730,7 @@ makeConditional lbl parent discrim otherInputs cases = do where makeCase :: NodeId -> String -> Int -> [HugrType] -> (NodeId -> [TypedPort] -> Compile [TypedPort]) -> Compile [HugrType] makeCase parent name ix tys f = do - caseId <- freshNodeWithParent name parent + caseId <- freshNode name parent inpId <- addNode ("Input_" ++ name) (caseId, OpIn (InputNode tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) outs <- f caseId (zipWith (\offset ty -> (Port inpId offset, ty)) [0..] tys) let outTys = snd <$> outs diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index c2d4e4f4..fe68aa55 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Data.HugrGraph(Hugr, NodeId, PortId(..), newWithRoot, splitNamespace, rootNode, - freshNodeWithParent, setOp, getParent, getOp, + freshNode, setOp, getParent, getOp, addEdge, addOrderEdge, edgeList, serialize ) where @@ -36,8 +36,8 @@ splitNamespace :: Hugr -> String -> (Namespace, Hugr) splitNamespace hugr n = let (nsx, nsNew) = split n (nameSupply hugr) in (nsx, hugr {nameSupply = nsNew}) -freshNodeWithParent :: Hugr -> NodeId -> String -> (NodeId, Hugr) -freshNodeWithParent hugr@(HugrGraph {parents, nameSupply}) parent nam = +freshNode :: Hugr -> NodeId -> String -> (NodeId, Hugr) +freshNode hugr@(HugrGraph {parents, nameSupply}) parent nam = case M.lookup parent parents of Nothing -> error "parent does not exist" Just _ -> let (freshName, newSupply) = fresh nam nameSupply From df8b4ddfe3c23ce6d05dc08091286f1c2baf0429 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 18 Dec 2025 10:57:27 +0000 Subject: [PATCH 018/149] makeCS takes Hugr --- brat/Brat/Compile/Hugr.hs | 35 ++++++++++++++++------------------- 1 file changed, 16 insertions(+), 19 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 9a2eba7f..8bfc7ec2 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -69,21 +69,18 @@ data CompilationState = CompilationState , decls :: M.Map Name (NodeId, Bool) } -makeCS :: (Graph, CaptureSets, Namespace, Store) -> String -> HugrOp -> (NodeId, CompilationState) -makeCS (g, cs, ns, store) rootNam rootOp = - let (hugr, rootNode) = H.newWithRoot ns rootNam rootOp - in (rootNode - ,CompilationState - { bratGraph = g - , capSets = cs - , hugr = hugr - , compiled = M.empty - , holes = B0 - , liftedOutPorts = M.empty - , store = store - , decls = M.empty - } - ) +makeCS :: (Graph, CaptureSets, Store) -> H.Hugr -> CompilationState +makeCS (g, cs, store) hugr = + CompilationState + { bratGraph = g + , capSets = cs + , hugr = hugr + , compiled = M.empty + , holes = B0 + , liftedOutPorts = M.empty + , store = store + , decls = M.empty + } registerFuncDef :: Name -> (NodeId, Bool) -> Compile () registerFuncDef name hugrDef = do @@ -523,8 +520,8 @@ compileConstDfg parent desc (inTys, outTys) contents = do let (nsx, hugr') = H.splitNamespace (hugr s) desc put s {hugr=hugr'} -- And pass that namespace into nested monad that compiles the DFG - let (dfg_id, nestedState) = makeCS (g,cs,nsx,st) ("Box_" ++ show desc) (OpDFG $ DFG funTy []) - let (a, compState) = runState (contents dfg_id) nestedState + let (h, dfg_id) = H.newWithRoot nsx ("Box_" ++ show desc) (OpDFG $ DFG funTy []) + let (a, compState) = runState (contents dfg_id) (makeCS (g,cs,st) h) let nestedHugr = renameAndSortHugr (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy @@ -878,11 +875,11 @@ compile :: Store -> VEnv -> BS.ByteString compile store ns g capSets venv = - let (moduleNode, initState) = makeCS (g, capSets, ns, store) "module" (OpMod ModuleOp) + let (hugr, moduleNode) = H.newWithRoot ns "module" (OpMod ModuleOp) in evalState (trackM "compileFunctions" *> compileModule venv moduleNode *> trackM "dumpJSON" *> dumpJSON ) - initState + (makeCS (g, capSets, store) hugr) From 1cfebd17e11c3a69f84d92e63e802e3f82d6dc56 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 18 Dec 2025 10:58:06 +0000 Subject: [PATCH 019/149] compileBox takes Container = 3*NodeId, uses setOp; {freshNode,new}WithIO --- brat/Brat/Compile/Hugr.hs | 103 ++++++++++++++++++++++---------------- brat/Data/HugrGraph.hs | 45 ++++++++++++++--- 2 files changed, 97 insertions(+), 51 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 8bfc7ec2..9d763431 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -24,7 +24,7 @@ import Brat.Syntax.Value import Bwd import Control.Monad.Freer import Data.Hugr -import Data.HugrGraph (NodeId) +import Data.HugrGraph (Container, NodeId) import qualified Data.HugrGraph as H import Hasochism @@ -94,6 +94,13 @@ freshNode name parent = do put s {hugr = h} pure id +freshNodeWithIO :: String -> NodeId -> Compile Container +freshNodeWithIO name parent = do + s <- get + let (ctr, h) = H.freshNodeWithIO (hugr s) parent name + put s {hugr = h} + pure ctr + addEdge :: (PortId NodeId, PortId NodeId) -> Compile () addEdge e = get >>= \st -> put (st { hugr = H.addEdge (hugr st) e }) @@ -263,15 +270,17 @@ compileClauses parent ins ((matchData, rhs) :| clauses) = do didMatch :: [HugrType] -> NodeId -> [TypedPort] -> Compile [TypedPort] didMatch outTys parent ins = gets bratGraph >>= \(ns,_) -> case ns M.! rhs of BratNode (Box src tgt) _ _ -> do - dfgId <- addNode "DidMatch_DFG" (parent, OpDFG (DFG (FunctionType (snd <$> ins) outTys bratExts) [])) - compileBox (src, tgt) dfgId + ctr <- freshNodeWithIO "DidMatch" parent + let dfgId = H.parent ctr + setOp dfgId (OpDFG (DFG (FunctionType (snd <$> ins) outTys bratExts) [])) + compileBox ctr (src, tgt) for_ (zip (fst <$> ins) (Port dfgId <$> [0..])) addEdge pure $ zip (Port dfgId <$> [0..]) outTys _ -> error "RHS should be a box node" -compileBox :: (Name, Name) -> NodeId -> Compile () +compileBox :: Container -> (Name, Name) -> Compile () -- note: we used to compile only KernelNode's here, this may not be right -compileBox (src, tgt) parent = do +compileBox (H.Ctr parent srcN tgtN) (src, tgt) = do -- Compile Source node <- gets ((M.! src) . fst . bratGraph) trackM ("compileSource (" ++ show parent ++ ") " ++ show src ++ " " ++ show node) @@ -279,22 +288,22 @@ compileBox (src, tgt) parent = do (BratNode Source [] outs) -> outs (KernelNode Source [] outs) -> outs srcTys <- compilePorts src_outs - srcNode <- addNode "Input" (parent, OpIn (InputNode srcTys [("source", "Source"), ("parent", show parent)])) - registerCompiled src srcNode - compileTarget parent tgt + setOp srcN (OpIn (InputNode srcTys [("source", "Source"), ("parent", show parent)])) + registerCompiled src srcN + compileTarget parent tgtN tgt -compileTarget :: NodeId -> Name -> Compile () -compileTarget parent tgt = do +compileTarget :: NodeId -> NodeId -> Name -> Compile () +compileTarget parent tgtN tgt = do node <- gets ((M.! tgt) . fst . bratGraph) trackM ("compileTarget (" ++ show parent ++ ") " ++ show tgt ++ " " ++ show node) let tgt_ins = case node of (BratNode Target ins []) -> ins (KernelNode Target ins []) -> ins tgtTys <- compilePorts tgt_ins - tgtNode <- addNode "Output" (parent, OpOut (OutputNode tgtTys [("source", "Target")])) + setOp tgtN (OpOut (OutputNode tgtTys [("source", "Target")])) edges <- compileInEdges parent tgt - -- registerCompiled tgt tgtNode -- really shouldn't be necessary, not reachable - for_ edges (\(src, tgtPort) -> addEdge (src, Port tgtNode tgtPort)) + -- registerCompiled tgt tgtN -- really shouldn't be necessary, not reachable + for_ edges (\(src, tgtPort) -> addEdge (src, Port tgtN tgtPort)) pure () in_edges :: Name -> Compile [((OutPort, Val Z), Int)] @@ -396,10 +405,12 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case let [(_, VFun Braty cty)] = outs boxSig@(inputTys, outputTys) <- compileSig Braty cty let boxFunTy = FunctionType inputTys outputTys bratExts - ((Port loadConst _, _ty), ()) <- compileConstDfg parent n boxSig $ \dfgId -> do - ins <- addNodeWithInputs ("Inputs" ++ n) (dfgId, OpIn (InputNode inputTys [("source", "Prim")])) [] inputTys - outs <- addNodeWithInputs n (dfgId, OpCustom (CustomOp ext op boxFunTy [])) ins outputTys - addNodeWithInputs ("Outputs" ++ n) (dfgId, OpOut (OutputNode outputTys [("source", "Prim")])) outs [] + ((Port loadConst _, _ty), ()) <- compileConstDfg parent n boxSig $ \ctr -> do + setOp (H.input ctr) (OpIn (InputNode inputTys [("source", "Prim")])) + let ins = zip (Port (H.input ctr) <$> [0..]) inputTys + outs <- addNodeWithInputs n (H.parent ctr, OpCustom (CustomOp ext op boxFunTy [])) ins outputTys + setOp (H.output ctr) (OpOut (OutputNode outputTys [("source", "Prim")])) + for_ (zip (fst <$> outs) (Port (H.output ctr) <$> [0..])) addEdge pure () pure $ default_edges loadConst @@ -465,10 +476,12 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case PatternMatch cs -> default_edges <$> do ins <- compilePorts ins outs <- compilePorts outs - dfgId <- addNode "PatternMatch_DFG" (parent, OpDFG (DFG (FunctionType ins outs bratExts) [])) - inputNode <- addNode "PatternMatch.Input" (dfgId, OpIn (InputNode ins [("source", "PatternMatch"), ("parent", show dfgId)])) + (H.Ctr dfgId inputNode outputNode) <- freshNodeWithIO "PatternMatch" parent + setOp dfgId (OpDFG (DFG (FunctionType ins outs bratExts) [])) + setOp inputNode (OpIn (InputNode ins [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts <- compileClauses dfgId (zip (Port inputNode <$> [0..]) ins) cs - addNodeWithInputs "PatternMatch.Output" (dfgId, OpOut (OutputNode (snd <$> ccOuts) [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts [] + setOp outputNode (OpOut (OutputNode (snd <$> ccOuts) [("source", "PatternMatch"), ("parent", show dfgId)])) + for_ (zip (fst <$> ccOuts) (Port outputNode <$> [0..])) addEdge pure dfgId ArithNode op -> default_edges <$> compileArithNode parent op (snd $ head ins) Selector _c -> error "Todo: selector" @@ -509,7 +522,7 @@ getOutPort parent p@(Ex srcNode srcPort) = do -- Execute a compilation (which takes a DFG parent) in a nested monad; -- produce a Const node containing the resulting Hugr, and a LoadConstant, -- and return the latter. -compileConstDfg :: NodeId -> String -> ([HugrType], [HugrType]) -> (NodeId -> Compile a) -> Compile (TypedPort, a) +compileConstDfg :: NodeId -> String -> ([HugrType], [HugrType]) -> (Container -> Compile a) -> Compile (TypedPort, a) compileConstDfg parent desc (inTys, outTys) contents = do st <- gets store g <- gets bratGraph @@ -520,8 +533,8 @@ compileConstDfg parent desc (inTys, outTys) contents = do let (nsx, hugr') = H.splitNamespace (hugr s) desc put s {hugr=hugr'} -- And pass that namespace into nested monad that compiles the DFG - let (h, dfg_id) = H.newWithRoot nsx ("Box_" ++ show desc) (OpDFG $ DFG funTy []) - let (a, compState) = runState (contents dfg_id) (makeCS (g,cs,st) h) + let (h, ctr) = H.newWithIO nsx ("Box_" ++ show desc) (OpDFG $ DFG funTy []) + let (a, compState) = runState (contents ctr) (makeCS (g,cs,st) h) let nestedHugr = renameAndSortHugr (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy @@ -546,8 +559,9 @@ compileBratBox parent name (venv, src, tgt) cty = do let allInputTys = parmTys ++ inputTys let boxInnerSig = FunctionType allInputTys outputTys bratExts - (templatePort, _) <- compileConstDfg parent ("BB" ++ show name) (allInputTys, outputTys) $ \dfgId -> do - src_id <- addNode ("LiftedCapturesInputs" ++ show name) (dfgId, OpIn (InputNode allInputTys [("source", "compileBratBox")])) + (templatePort, _) <- compileConstDfg parent ("BB" ++ show name) (allInputTys, outputTys) $ \ctr -> do + let src_id = H.input ctr -- would be good to name "LiftedCapturedInputs" + setOp src_id (OpIn (InputNode allInputTys [("source", "compileBratBox")])) -- Now map ports in the BRAT Graph to their Hugr equivalents. -- Each captured value is read from an element of src_id, starting from 0 let lifted = [(src, Port src_id i) | ((src, _ty), i) <- zip params [0..]] @@ -556,7 +570,7 @@ compileBratBox parent name (venv, src, tgt) cty = do st <- get put $ st {liftedOutPorts = M.fromList lifted} -- no need to return any holes - compileTarget dfgId tgt + compileTarget (H.parent ctr) (H.output ctr) tgt -- Finally, we add a `Partial` node to supply the captured params. partialNode <- addNode "Partial" (parent, OpCustom $ partialOp boxInnerSig (length params)) @@ -572,8 +586,8 @@ compileKernBox parent desc src_tgt cty = do -- return a Hugr with holes boxInnerSig@(inTys, outTys) <- compileSig Kerny cty let boxTy = HTFunc $ PolyFuncType [] (FunctionType inTys outTys bratExts) - (templatePort, holelist) <- compileConstDfg parent ("KB" ++ desc) boxInnerSig $ \dfg_id -> do - compileBox src_tgt dfg_id + (templatePort, holelist) <- compileConstDfg parent ("KB" ++ desc) boxInnerSig $ \ctr -> do + compileBox ctr src_tgt gets holes -- For each hole in the template (index 0 i.e. earliest, first) @@ -727,11 +741,11 @@ makeConditional lbl parent discrim otherInputs cases = do where makeCase :: NodeId -> String -> Int -> [HugrType] -> (NodeId -> [TypedPort] -> Compile [TypedPort]) -> Compile [HugrType] makeCase parent name ix tys f = do - caseId <- freshNode name parent - inpId <- addNode ("Input_" ++ name) (caseId, OpIn (InputNode tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) + (H.Ctr caseId inpId outId) <- freshNodeWithIO name parent + setOp inpId (OpIn (InputNode tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) outs <- f caseId (zipWith (\offset ty -> (Port inpId offset, ty)) [0..] tys) let outTys = snd <$> outs - outId <- addNode ("Output" ++ name) (caseId, OpOut (OutputNode outTys [("source", "makeCase")])) + setOp outId (OpOut (OutputNode outTys [("source", "makeCase")])) for_ (zip (fst <$> outs) (Port outId <$> [0..])) addEdge setOp caseId (OpCase (ix, Case (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) pure outTys @@ -800,9 +814,10 @@ compileModule venv moduleNode = do -- to compute its value. bodies <- for decls (\(fnName, idNode) -> do (funTy, extra_call, body) <- analyseDecl idNode - defNode <- addNode (show fnName ++ "_def") (moduleNode, OpDefn $ FuncDefn (show fnName) funTy []) - registerFuncDef idNode (defNode, extra_call) - pure (body defNode) + ctr@H.Ctr {parent} <- freshNodeWithIO (show fnName ++ "_def") moduleNode + setOp parent (OpDefn $ FuncDefn (show fnName) funTy []) + registerFuncDef idNode (parent, extra_call) + pure (body ctr) ) for_ bodies (\body -> do st <- get @@ -817,7 +832,7 @@ compileModule venv moduleNode = do -- return the type of the Hugr FuncDefn, whether said FuncDefn requires an extra Call, -- and the procedure for compiling the contents of the FuncDefn for execution later, -- *after* all such FuncDefns have been registered - analyseDecl :: Name -> Compile (PolyFuncType, Bool, NodeId -> Compile ()) + analyseDecl :: Name -> Compile (PolyFuncType, Bool, Container -> Compile ()) analyseDecl idNode = do (ns, es) <- gets bratGraph let srcPortTys = [(srcPort, ty) | (srcPort, ty, In tgt _) <- es, tgt == idNode ] @@ -827,7 +842,7 @@ compileModule venv moduleNode = do case outs of [(_, VFun Braty cty)] -> do (inTys, outTys) <- compileSig Braty cty - pure (PolyFuncType [] (FunctionType inTys outTys bratExts), False, compileBox (src, tgt)) + pure (PolyFuncType [] (FunctionType inTys outTys bratExts), False, flip compileBox (src, tgt)) [(_, VFun Kerny cty)] -> do -- We're compiling, e.g. -- f :: { Qubit -o Qubit } @@ -836,9 +851,9 @@ compileModule venv moduleNode = do -- computation that produces this constant. We do so by making a FuncDefn -- that takes no arguments and produces the constant kernel graph value. thunkTy <- HTFunc . PolyFuncType [] . (\(ins, outs) -> FunctionType ins outs bratExts) <$> compileSig Kerny cty - pure (funcReturning [thunkTy], True, \parent -> do - addNode "input" (parent, OpIn (InputNode [] [("source", "analyseDecl")])) - output <- addNode "output" (parent, OpOut (OutputNode [thunkTy] [("source", "analyseDecl")])) + pure (funcReturning [thunkTy], True, \H.Ctr {parent,input,output} -> do + setOp input (OpIn (InputNode [] [("source", "analyseDecl")])) + setOp output (OpOut (OutputNode [thunkTy] [("source", "analyseDecl")])) wire <- compileKernBox parent (show input) (src, tgt) cty addEdge (fst wire, Port output 0)) _ -> error "Box should have exactly one output of Thunk type" @@ -858,10 +873,10 @@ compileModule venv moduleNode = do funcReturning :: [HugrType] -> PolyFuncType funcReturning outs = PolyFuncType [] (FunctionType [] outs bratExts) -compileNoun :: [HugrType] -> [OutPort] -> NodeId -> Compile () -compileNoun outs srcPorts parent = do - addNode "input" (parent, OpIn (InputNode [] [("source", "compileNoun")])) - output <- addNode "output" (parent, OpOut (OutputNode outs [("source", "compileNoun")])) +compileNoun :: [HugrType] -> [OutPort] -> Container -> Compile () +compileNoun outs srcPorts H.Ctr {parent, input, output} = do + setOp input (OpIn (InputNode [] [("source", "compileNoun")])) + setOp output (OpOut (OutputNode outs [("source", "compileNoun")])) for_ (zip [0..] srcPorts) (\(outport, Ex src srcPort) -> compileWithInputs parent src >>= \case Just nodeId -> addEdge (Port nodeId srcPort, Port output outport) $> () @@ -875,7 +890,7 @@ compile :: Store -> VEnv -> BS.ByteString compile store ns g capSets venv = - let (hugr, moduleNode) = H.newWithRoot ns "module" (OpMod ModuleOp) + let (hugr, moduleNode) = H.newModule ns "module" in evalState (trackM "compileFunctions" *> compileModule venv moduleNode *> diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index fe68aa55..cb2d72d2 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module Data.HugrGraph(Hugr, NodeId, PortId(..), - newWithRoot, splitNamespace, rootNode, - freshNode, setOp, getParent, getOp, +module Data.HugrGraph(NodeId, PortId(..), Container(..), + Hugr, -- do NOT export contents, keep abstract + newWithIO, newModule, splitNamespace, rootNode, + freshNode, freshNodeWithIO, + setOp, getParent, getOp, addEdge, addOrderEdge, edgeList, serialize ) where @@ -18,6 +20,12 @@ import qualified Data.Map as M newtype NodeId = NodeId Name deriving (Eq, Ord, Show) +data Container = Ctr { + parent :: NodeId, + input :: NodeId, + output :: NodeId +} + data Hugr = HugrGraph { -- exactly one node (the root) will have parent == self parents :: M.Map NodeId NodeId, @@ -46,6 +54,13 @@ freshNode hugr@(HugrGraph {parents, nameSupply}) parent nam = parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents }) +freshNodeWithIO :: Hugr -> NodeId -> String -> (Container, Hugr) +freshNodeWithIO h gparent desc = + let (parent, h2) = freshNode h gparent desc + (input, h3) = freshNode h2 parent (desc ++ "_Input") + (output, h4) = freshNode h3 parent (desc ++ "_Output") + in (Ctr {parent, input, output}, h4) + setOp :: Hugr -> NodeId -> HugrOp -> Hugr -- Insist the parent exists setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of @@ -54,18 +69,34 @@ setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of -- alter + partial match is just to fail if key already present h { nodes = M.alter (\Nothing -> Just op) name nodes } -newWithRoot :: Namespace -> String -> HugrOp -> (Hugr, NodeId) -newWithRoot ns nam op = +newWithIO :: Namespace -> String -> HugrOp -> (Hugr, Container) +newWithIO ns nam op = + let (name, ns1) = fresh nam ns + (input, ns2) = fresh (nam ++ "_Input") ns1 + (output, ns3) = fresh (nam ++ "_Output") ns2 + node = NodeId name + in (HugrGraph { + parents = M.fromList ((, node) <$> [node, NodeId input, NodeId output]), + nodes = M.singleton node op, + edges_in = M.empty, + edges_out = M.empty, + nameSupply = ns3 + } + ,Ctr node (NodeId input) (NodeId output) + ) + +newModule :: Namespace -> String -> (Hugr, NodeId) +newModule ns nam = let (name, ns') = fresh nam ns node = NodeId name in (HugrGraph { parents = M.singleton node node, - nodes = M.singleton node op, + nodes = M.singleton node (OpMod ModuleOp), edges_in = M.empty, edges_out = M.empty, nameSupply = ns' } - ,node + , node ) addEdge :: Hugr -> (PortId NodeId, PortId NodeId) -> Hugr From 57f211064ecbf00a80f104a15c249cbbf99807f5 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 18 Dec 2025 11:08:26 +0000 Subject: [PATCH 020/149] HugrGraph: separate out root --- brat/Data/HugrGraph.hs | 53 +++++++++++++++++++----------------------- 1 file changed, 24 insertions(+), 29 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index cb2d72d2..a1cdade3 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Data.HugrGraph(NodeId, PortId(..), Container(..), Hugr, -- do NOT export contents, keep abstract - newWithIO, newModule, splitNamespace, rootNode, + newWithIO, newModule, splitNamespace, freshNode, freshNodeWithIO, setOp, getParent, getOp, addEdge, addOrderEdge, @@ -12,7 +12,7 @@ import Brat.Naming import Data.Hugr hiding (Hugr) import qualified Data.Hugr as D -import Data.List (partition, sortBy) +import Data.List (sortBy) import Data.Maybe (fromMaybe) import Data.Ord (comparing) import Data.Tuple (swap) @@ -27,32 +27,27 @@ data Container = Ctr { } data Hugr = HugrGraph { - -- exactly one node (the root) will have parent == self - parents :: M.Map NodeId NodeId, + root :: NodeId, + parents :: M.Map NodeId NodeId, -- definitive list of (valid) nodes, excluding root nodes :: M.Map NodeId HugrOp, edges_out :: M.Map NodeId [(Int, PortId NodeId)], edges_in :: M.Map NodeId [(PortId NodeId, Int)], nameSupply :: Namespace } deriving (Eq, Show) -- we probably want a better `show` --- Quite inefficient on arbitrary Hugr but used only when we know there are few nodes -rootNode :: Hugr -> NodeId -rootNode HugrGraph {parents} = let [root] = [node | (node,parent) <- M.assocs parents, node == parent] - in root - splitNamespace :: Hugr -> String -> (Namespace, Hugr) splitNamespace hugr n = let (nsx, nsNew) = split n (nameSupply hugr) in (nsx, hugr {nameSupply = nsNew}) freshNode :: Hugr -> NodeId -> String -> (NodeId, Hugr) -freshNode hugr@(HugrGraph {parents, nameSupply}) parent nam = +freshNode hugr@(HugrGraph {root, parents, nameSupply}) parent nam = case M.lookup parent parents of - Nothing -> error "parent does not exist" - Just _ -> let (freshName, newSupply) = fresh nam nameSupply - in (NodeId freshName, hugr { - nameSupply = newSupply, - parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents - }) + Nothing | parent /= root-> error "parent does not exist" + _ -> let (freshName, newSupply) = fresh nam nameSupply + in (NodeId freshName, hugr { + nameSupply = newSupply, + parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents + }) freshNodeWithIO :: Hugr -> NodeId -> String -> (Container, Hugr) freshNodeWithIO h gparent desc = @@ -74,29 +69,31 @@ newWithIO ns nam op = let (name, ns1) = fresh nam ns (input, ns2) = fresh (nam ++ "_Input") ns1 (output, ns3) = fresh (nam ++ "_Output") ns2 - node = NodeId name + root = NodeId name in (HugrGraph { - parents = M.fromList ((, node) <$> [node, NodeId input, NodeId output]), - nodes = M.singleton node op, + root, + parents = M.fromList ((, root) . NodeId <$> [input, output]), + nodes = M.singleton root op, edges_in = M.empty, edges_out = M.empty, nameSupply = ns3 } - ,Ctr node (NodeId input) (NodeId output) + ,Ctr root (NodeId input) (NodeId output) ) newModule :: Namespace -> String -> (Hugr, NodeId) newModule ns nam = let (name, ns') = fresh nam ns - node = NodeId name + root = NodeId name in (HugrGraph { - parents = M.singleton node node, - nodes = M.singleton node (OpMod ModuleOp), + root, + parents = M.empty, + nodes = M.singleton root (OpMod ModuleOp), edges_in = M.empty, edges_out = M.empty, nameSupply = ns' } - , node + , root ) addEdge :: Hugr -> (PortId NodeId, PortId NodeId) -> Hugr @@ -125,15 +122,13 @@ getOp :: Hugr -> NodeId -> HugrOp getOp HugrGraph {nodes} n = nodes M.! n serialize :: Hugr -> D.Hugr Int -serialize hugr@(HugrGraph {nodes, parents}) = D.Hugr ( +serialize hugr@(HugrGraph {root, nodes, parents}) = D.Hugr ( [(transNode parent, op) | (op, parent) <- snd <$> sortedNodes], [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] ) where sortedNodes :: [(NodeId, (HugrOp, NodeId))] -- name, (op, parent) - sortedNodes = let nodesWithParents = [(name, (nodes M.! name, parent)) | (name, parent) <- M.assocs parents] - isRoot (name, (_op, parent)) = name == parent - ([root], rest) = partition isRoot nodesWithParents - in root:(sortBy (comparing swap) rest) + sortedNodes = let withOp (name, parent) = (name, (nodes M.! name, parent)) + in (withOp (root, root)):(sortBy (comparing swap) (withOp <$> M.assocs parents)) transNode :: NodeId -> Int transNode = ((M.fromList $ zip (fst <$> sortedNodes) [0..]) M.!) From a79153016512e57f49e64dd50405cb2d7c69b305 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 18 Dec 2025 11:13:01 +0000 Subject: [PATCH 021/149] HugrGraph: add io_children (written not read) --- brat/Data/HugrGraph.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index a1cdade3..849f4067 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -29,6 +29,7 @@ data Container = Ctr { data Hugr = HugrGraph { root :: NodeId, parents :: M.Map NodeId NodeId, -- definitive list of (valid) nodes, excluding root + io_children:: M.Map NodeId (NodeId, NodeId), nodes :: M.Map NodeId HugrOp, edges_out :: M.Map NodeId [(Int, PortId NodeId)], edges_in :: M.Map NodeId [(PortId NodeId, Int)], @@ -54,7 +55,7 @@ freshNodeWithIO h gparent desc = let (parent, h2) = freshNode h gparent desc (input, h3) = freshNode h2 parent (desc ++ "_Input") (output, h4) = freshNode h3 parent (desc ++ "_Output") - in (Ctr {parent, input, output}, h4) + in (Ctr {parent, input, output}, h4 {io_children = M.insert parent (input, output) (io_children h4) }) setOp :: Hugr -> NodeId -> HugrOp -> Hugr -- Insist the parent exists @@ -67,18 +68,19 @@ setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of newWithIO :: Namespace -> String -> HugrOp -> (Hugr, Container) newWithIO ns nam op = let (name, ns1) = fresh nam ns - (input, ns2) = fresh (nam ++ "_Input") ns1 - (output, ns3) = fresh (nam ++ "_Output") ns2 - root = NodeId name + (inp, ns2) = fresh (nam ++ "_Input") ns1 + (outp, ns3) = fresh (nam ++ "_Output") ns2 + (root, input, output) = (NodeId name, NodeId inp, NodeId outp) in (HugrGraph { root, - parents = M.fromList ((, root) . NodeId <$> [input, output]), + parents = M.fromList ((, root) <$> [input, output]), + io_children = M.singleton root (input, output), nodes = M.singleton root op, edges_in = M.empty, edges_out = M.empty, nameSupply = ns3 } - ,Ctr root (NodeId input) (NodeId output) + ,Ctr {parent=root, input, output} ) newModule :: Namespace -> String -> (Hugr, NodeId) @@ -88,6 +90,7 @@ newModule ns nam = in (HugrGraph { root, parents = M.empty, + io_children = M.empty, nodes = M.singleton root (OpMod ModuleOp), edges_in = M.empty, edges_out = M.empty, From e6cecd70fd6dba97f92a289edf2faef8baae3e4d Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 18 Dec 2025 12:33:40 +0000 Subject: [PATCH 022/149] WIP use io_children to sort Hugr. Fails on Conditionals - cases in wrong order?? --- brat/Data/HugrGraph.hs | 36 ++++++++++++++++++++++++++++-------- 1 file changed, 28 insertions(+), 8 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 849f4067..f882f8c5 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -10,12 +10,12 @@ module Data.HugrGraph(NodeId, PortId(..), Container(..), import Brat.Naming +import Bwd import Data.Hugr hiding (Hugr) import qualified Data.Hugr as D -import Data.List (sortBy) + +import Data.Bifunctor (first) import Data.Maybe (fromMaybe) -import Data.Ord (comparing) -import Data.Tuple (swap) import qualified Data.Map as M newtype NodeId = NodeId Name deriving (Eq, Ord, Show) @@ -124,14 +124,34 @@ getParent HugrGraph {parents} n = parents M.! n getOp :: Hugr -> NodeId -> HugrOp getOp HugrGraph {nodes} n = nodes M.! n +-- this should be local to serialize but local `type` is not allowed +type StackAndIndices = (Bwd (NodeId, HugrOp) -- node is index, this is (parent, op) + , M.Map NodeId Int) + serialize :: Hugr -> D.Hugr Int serialize hugr@(HugrGraph {root, nodes, parents}) = D.Hugr ( - [(transNode parent, op) | (op, parent) <- snd <$> sortedNodes], + (first transNode) <$> (fst nodeStackAndIndices) <>> [], [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] ) where - sortedNodes :: [(NodeId, (HugrOp, NodeId))] -- name, (op, parent) - sortedNodes = let withOp (name, parent) = (name, (nodes M.! name, parent)) - in (withOp (root, root)):(sortBy (comparing swap) (withOp <$> M.assocs parents)) + + nodeStackAndIndices :: StackAndIndices + nodeStackAndIndices = foldl addNode + (B0 :< (root, nodes M.! root), M.singleton root 0) + (M.keys parents) + + addNode :: StackAndIndices -> NodeId -> StackAndIndices + addNode ins n = case M.lookup n (snd ins) of + (Just _) -> ins + Nothing -> let + parent = parents M.! n -- guaranteed as root is always in `ins` + with_parent@(stack, indices) = addNode ins parent -- add parent first, will recurse up + in case M.lookup n indices of + Just _ -> with_parent -- self added by recursive call; we must be in parent's io_children + Nothing -> let with_n = (stack :< (parent, nodes M.! n), M.insert n (M.size indices) indices) + in case M.lookup n (io_children hugr) of + -- finally add io_children immediately after + (Just (inp, out)) -> addNode (addNode with_n inp) out + Nothing -> with_n transNode :: NodeId -> Int - transNode = ((M.fromList $ zip (fst <$> sortedNodes) [0..]) M.!) + transNode = ((snd nodeStackAndIndices) M.!) From af23d7e472eab201419bade854178ae576a4fece Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 18 Dec 2025 13:25:14 +0000 Subject: [PATCH 023/149] hack setFirstChildren to get Cases in order inside Conditional --- brat/Brat/Compile/Hugr.hs | 18 ++++++++++-------- brat/Data/HugrGraph.hs | 6 ++++++ 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 9d763431..8f0f3779 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -729,17 +729,19 @@ makeConditional :: String -- Label makeConditional lbl parent discrim otherInputs cases = do condId <- freshNode "Conditional" parent let rows = getSumVariants (snd discrim) - outTyss <- for (zip (zip [0..] cases) rows) (\((ix, (name, f)), row) -> makeCase condId name ix (row ++ (snd <$> otherInputs)) f) - unless - (allRowsEqual outTyss) - (error "Conditional output types didn't match") - let condOp = OpConditional (Conditional rows (snd <$> otherInputs) (head outTyss) [("label", lbl)]) + (outTyss_cases) <- for (zip (zip [0..] cases) rows) (\((ix, (name, f)), row) -> makeCase condId name ix (row ++ (snd <$> otherInputs)) f) + let outTys = if allRowsEqual (fst <$> outTyss_cases) + then fst (head outTyss_cases) + else (error "Conditional output types didn't match") + let condOp = OpConditional (Conditional rows (snd <$> otherInputs) outTys [("label", lbl)]) setOp condId condOp + s <- get + put s {hugr = H.setFirstChildren (hugr s) condId (snd <$> outTyss_cases)} addEdge (fst discrim, Port condId 0) traverse_ addEdge (zip (fst <$> otherInputs) (Port condId <$> [1..])) - pure $ zip (Port condId <$> [0..]) (head outTyss) + pure $ zip (Port condId <$> [0..]) outTys where - makeCase :: NodeId -> String -> Int -> [HugrType] -> (NodeId -> [TypedPort] -> Compile [TypedPort]) -> Compile [HugrType] + makeCase :: NodeId -> String -> Int -> [HugrType] -> (NodeId -> [TypedPort] -> Compile [TypedPort]) -> Compile ([HugrType], NodeId) makeCase parent name ix tys f = do (H.Ctr caseId inpId outId) <- freshNodeWithIO name parent setOp inpId (OpIn (InputNode tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) @@ -748,7 +750,7 @@ makeConditional lbl parent discrim otherInputs cases = do setOp outId (OpOut (OutputNode outTys [("source", "makeCase")])) for_ (zip (fst <$> outs) (Port outId <$> [0..])) addEdge setOp caseId (OpCase (ix, Case (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) - pure outTys + pure (outTys, caseId) allRowsEqual :: [[HugrType]] -> Bool allRowsEqual [] = True diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index f882f8c5..40b194d1 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -3,6 +3,7 @@ module Data.HugrGraph(NodeId, PortId(..), Container(..), Hugr, -- do NOT export contents, keep abstract newWithIO, newModule, splitNamespace, freshNode, freshNodeWithIO, + setFirstChildren, setOp, getParent, getOp, addEdge, addOrderEdge, edgeList, serialize @@ -57,6 +58,11 @@ freshNodeWithIO h gparent desc = (output, h4) = freshNode h3 parent (desc ++ "_Output") in (Ctr {parent, input, output}, h4 {io_children = M.insert parent (input, output) (io_children h4) }) +-- This is a hack to deal with Conditionals, whose cases must be ordered. +-- For now it only works if there are exactly two cases... +setFirstChildren :: Hugr -> NodeId -> [NodeId] -> Hugr +setFirstChildren h p [c1,c2] = h {io_children = M.alter (\Nothing -> Just (c1,c2)) p (io_children h)} + setOp :: Hugr -> NodeId -> HugrOp -> Hugr -- Insist the parent exists setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of From 5d0d815338b676bb43085878080e1a627ed98833 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 18 Dec 2025 13:31:23 +0000 Subject: [PATCH 024/149] Drop unused instance Ord, and index inside OpCase --- brat/Brat/Compile/Hugr.hs | 2 +- brat/Data/Hugr.hs | 57 +++------------------------------------ 2 files changed, 5 insertions(+), 54 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 8f0f3779..ce52ffee 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -749,7 +749,7 @@ makeConditional lbl parent discrim otherInputs cases = do let outTys = snd <$> outs setOp outId (OpOut (OutputNode outTys [("source", "makeCase")])) for_ (zip (fst <$> outs) (Port outId <$> [0..])) addEdge - setOp caseId (OpCase (ix, Case (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) + setOp caseId (OpCase (Case (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) pure (outTys, caseId) allRowsEqual :: [[HugrType]] -> Bool diff --git a/brat/Data/Hugr.hs b/brat/Data/Hugr.hs index 3cbff595..9791134d 100644 --- a/brat/Data/Hugr.hs +++ b/brat/Data/Hugr.hs @@ -243,9 +243,6 @@ valFromSimple Unit = hvUnit data ModuleOp = ModuleOp deriving (Eq, Show) -instance Ord ModuleOp where - compare _ _ = EQ - instance JSONParent ModuleOp where toJSONp ModuleOp parent = object ["parent" .= parent ,"op" .= ("Module" :: Text) @@ -257,9 +254,6 @@ data FuncDefn = FuncDefn , metadata :: [(String, String)] } deriving (Eq, Show) -instance Ord FuncDefn where - compare _ _ = EQ - instance JSONParent FuncDefn where toJSONp (FuncDefn { .. }) parent = object ["parent" .= parent ,"op" .= ("FuncDefn" :: Text) @@ -288,9 +282,6 @@ data ConstOp = ConstOp { const :: HugrValue } deriving (Eq, Show) -instance Ord ConstOp where - compare _ _ = EQ - instance JSONParent ConstOp where toJSONp (ConstOp {..}) parent = object ["parent" .= parent ,"op" .= ("Const" :: Text) @@ -304,9 +295,6 @@ data InputNode = InputNode , metadata :: [(String, String)] } deriving (Eq, Show) -instance Ord InputNode where - compare _ _ = EQ - instance JSONParent InputNode where toJSONp (InputNode types metadata) parent = object ["parent" .= parent ,"op" .= ("Input" :: Text) @@ -319,9 +307,6 @@ data OutputNode = OutputNode , metadata :: [(String, String)] } deriving (Eq, Show) -instance Ord OutputNode where - compare _ _ = EQ - instance JSONParent OutputNode where toJSONp (OutputNode { .. }) parent = object ["parent" .= parent ,"op" .= ("Output" :: Text) @@ -336,9 +321,6 @@ data Conditional = Conditional , metadata :: [(String, String)] } deriving (Eq, Show) -instance Ord Conditional where - compare _ _ = EQ - instance JSONParent Conditional where toJSONp (Conditional { .. }) parent = object ["op" .= ("Conditional" :: Text) @@ -355,9 +337,6 @@ data Case = Case , metadata :: [(String, String)] } deriving (Eq, Show) -instance Ord Case where - compare _ _ = EQ - instance JSONParent Case where toJSONp (Case { .. }) parent = object ["op" .= ("Case" :: Text) ,"parent" .= parent @@ -378,9 +357,6 @@ data DFG = DFG , metadata :: [(String, String)] } deriving (Eq, Show) -instance Ord DFG where - compare _ _ = EQ - instance JSONParent DFG where toJSONp (DFG { .. }) parent = object ["op" .= ("DFG" :: Text) ,"parent" .= parent @@ -394,9 +370,6 @@ data TagOp = TagOp , metadata :: [(String, String)] } deriving (Eq, Show) -instance Ord TagOp where - compare _ _ = EQ - instance JSONParent TagOp where toJSONp (TagOp tag variants metadata) parent = object ["parent" .= parent @@ -410,9 +383,6 @@ data MakeTupleOp = MakeTupleOp { tys :: [HugrType] } deriving (Eq, Show) -instance Ord MakeTupleOp where - compare _ _ = EQ - instance JSONParent MakeTupleOp where toJSONp (MakeTupleOp tys) parent = object ["parent" .= parent @@ -427,9 +397,6 @@ data CustomOp = CustomOp , args :: [TypeArg] } deriving (Eq, Show) -instance Ord CustomOp where - compare _ _ = EQ - instance JSONParent CustomOp where toJSONp (CustomOp { .. }) parent = object ["parent" .= parent ,"op" .= ("CustomOp" :: Text) @@ -452,9 +419,6 @@ data CallOp = CallOp { signature_ :: FunctionType } deriving (Eq, Show) -instance Ord CallOp where - compare _ _ = EQ - instance JSONParent CallOp where toJSONp (CallOp signature_) parent = object ["parent" .= parent @@ -481,9 +445,6 @@ data CallIndirectOp = CallIndirectOp { signature_ :: FunctionType } deriving (Eq, Show) -instance Ord CallIndirectOp where - compare _ _ = EQ - instance JSONParent CallIndirectOp where toJSONp (CallIndirectOp signature_) parent = object ["parent" .= parent ,"signature" .= signature_ @@ -542,9 +503,6 @@ data LoadConstantOp = LoadConstantOp { datatype :: HugrType } deriving (Eq, Show) -instance Ord LoadConstantOp where - compare _ _ = EQ - instance JSONParent LoadConstantOp where toJSONp (LoadConstantOp {..}) parent = object ["parent" .= parent ,"op" .= ("LoadConstant" :: Text) @@ -557,9 +515,6 @@ data LoadFunctionOp = LoadFunctionOp , signature :: FunctionType } deriving (Eq, Show) -instance Ord LoadFunctionOp where - compare _ _ = EQ - instance JSONParent LoadFunctionOp where toJSONp (LoadFunctionOp {..}) parent = object ["parent" .= parent ,"op" .= ("LoadFunction" :: Text) @@ -572,9 +527,6 @@ data NoopOp = NoopOp { ty :: HugrType } deriving (Eq, Show) -instance Ord NoopOp where - compare _ _ = EQ - instance JSONParent NoopOp where toJSONp (NoopOp {..}) parent = object ["parent" .= parent ,"op" .= ("Noop" :: Text) @@ -592,8 +544,7 @@ data HugrOp | OpDFG DFG | OpConst ConstOp | OpConditional Conditional - -- Make sure that the cases are printed out in the correct order - | OpCase (Int, Case) + | OpCase Case | OpTag TagOp | OpMakeTuple MakeTupleOp | OpCustom CustomOp @@ -602,11 +553,11 @@ data HugrOp | OpLoadConstant LoadConstantOp | OpLoadFunction LoadFunctionOp | OpNoop NoopOp - deriving (Eq, Ord, Show) + deriving (Eq, Show) addMetadata :: [(String, String)] -> HugrOp -> HugrOp addMetadata md (OpDFG (DFG { .. })) = OpDFG (DFG { metadata = metadata ++ md, .. }) -addMetadata md (OpCase (i, (Case { .. }))) = OpCase (i, (Case { metadata = metadata ++ md, .. })) +addMetadata md (OpCase (Case { .. })) = OpCase (Case { metadata = metadata ++ md, .. }) addMetadata md (OpIn (InputNode { .. })) = OpIn (InputNode { metadata = metadata ++ md, .. }) addMetadata md (OpTag (TagOp { .. })) = OpTag (TagOp { metadata = metadata ++ md, .. }) addMetadata md (OpDefn (FuncDefn { .. })) = OpDefn (FuncDefn { metadata = metadata ++ md, .. }) @@ -620,7 +571,7 @@ instance JSONParent HugrOp where toJSONp (OpDFG op) parent = toJSONp op parent toJSONp (OpIn op) parent = toJSONp op parent toJSONp (OpOut op) parent = toJSONp op parent - toJSONp (OpCase (_, op)) parent = toJSONp op parent + toJSONp (OpCase op) parent = toJSONp op parent toJSONp (OpConditional op) parent = toJSONp op parent toJSONp (OpTag op) parent = toJSONp op parent toJSONp (OpMakeTuple op) parent = toJSONp op parent From d7ae8590ce62853161d6a6d5cc836c9ac19143c7 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 19 Dec 2025 21:40:36 +0000 Subject: [PATCH 025/149] Hugr->HugrGraph --- brat/Brat/Compile/Hugr.hs | 20 ++++++++++---------- brat/Data/HugrGraph.hs | 35 +++++++++++++++++------------------ 2 files changed, 27 insertions(+), 28 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index ce52ffee..062d3c34 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -24,7 +24,7 @@ import Brat.Syntax.Value import Bwd import Control.Monad.Freer import Data.Hugr -import Data.HugrGraph (Container, NodeId) +import Data.HugrGraph (HugrGraph, Container(..), NodeId) import qualified Data.HugrGraph as H import Hasochism @@ -53,7 +53,7 @@ type TypedPort = (PortId NodeId, HugrType) data CompilationState = CompilationState { bratGraph :: Graph -- the input BRAT Graph; should not be written , capSets :: CaptureSets -- environments captured by Box nodes in previous - , hugr :: H.Hugr + , hugr :: HugrGraph , compiled :: M.Map Name NodeId -- Mapping from Brat nodes to Hugr nodes -- When lambda lifting, captured variables become extra function inputs. -- This maps from the captured value (in the BRAT graph, perhaps outside the current func/lambda) @@ -69,7 +69,7 @@ data CompilationState = CompilationState , decls :: M.Map Name (NodeId, Bool) } -makeCS :: (Graph, CaptureSets, Store) -> H.Hugr -> CompilationState +makeCS :: (Graph, CaptureSets, Store) -> HugrGraph -> CompilationState makeCS (g, cs, store) hugr = CompilationState { bratGraph = g @@ -209,7 +209,7 @@ compileArithNode parent op TFloat = addNode (show op ++ "_Float") (parent, OpCus ) compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty -renameAndSortHugr :: H.Hugr -> Hugr Int +renameAndSortHugr :: HugrGraph -> Hugr Int renameAndSortHugr hugr = H.serialize (foldl H.addOrderEdge hugr orderEdges) where orderEdges :: [(NodeId, NodeId)] @@ -280,7 +280,7 @@ compileClauses parent ins ((matchData, rhs) :| clauses) = do compileBox :: Container -> (Name, Name) -> Compile () -- note: we used to compile only KernelNode's here, this may not be right -compileBox (H.Ctr parent srcN tgtN) (src, tgt) = do +compileBox (Ctr parent srcN tgtN) (src, tgt) = do -- Compile Source node <- gets ((M.! src) . fst . bratGraph) trackM ("compileSource (" ++ show parent ++ ") " ++ show src ++ " " ++ show node) @@ -476,7 +476,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case PatternMatch cs -> default_edges <$> do ins <- compilePorts ins outs <- compilePorts outs - (H.Ctr dfgId inputNode outputNode) <- freshNodeWithIO "PatternMatch" parent + (Ctr dfgId inputNode outputNode) <- freshNodeWithIO "PatternMatch" parent setOp dfgId (OpDFG (DFG (FunctionType ins outs bratExts) [])) setOp inputNode (OpIn (InputNode ins [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts <- compileClauses dfgId (zip (Port inputNode <$> [0..]) ins) cs @@ -743,7 +743,7 @@ makeConditional lbl parent discrim otherInputs cases = do where makeCase :: NodeId -> String -> Int -> [HugrType] -> (NodeId -> [TypedPort] -> Compile [TypedPort]) -> Compile ([HugrType], NodeId) makeCase parent name ix tys f = do - (H.Ctr caseId inpId outId) <- freshNodeWithIO name parent + (Ctr caseId inpId outId) <- freshNodeWithIO name parent setOp inpId (OpIn (InputNode tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) outs <- f caseId (zipWith (\offset ty -> (Port inpId offset, ty)) [0..] tys) let outTys = snd <$> outs @@ -816,7 +816,7 @@ compileModule venv moduleNode = do -- to compute its value. bodies <- for decls (\(fnName, idNode) -> do (funTy, extra_call, body) <- analyseDecl idNode - ctr@H.Ctr {parent} <- freshNodeWithIO (show fnName ++ "_def") moduleNode + ctr@Ctr {parent} <- freshNodeWithIO (show fnName ++ "_def") moduleNode setOp parent (OpDefn $ FuncDefn (show fnName) funTy []) registerFuncDef idNode (parent, extra_call) pure (body ctr) @@ -853,7 +853,7 @@ compileModule venv moduleNode = do -- computation that produces this constant. We do so by making a FuncDefn -- that takes no arguments and produces the constant kernel graph value. thunkTy <- HTFunc . PolyFuncType [] . (\(ins, outs) -> FunctionType ins outs bratExts) <$> compileSig Kerny cty - pure (funcReturning [thunkTy], True, \H.Ctr {parent,input,output} -> do + pure (funcReturning [thunkTy], True, \Ctr {parent,input,output} -> do setOp input (OpIn (InputNode [] [("source", "analyseDecl")])) setOp output (OpOut (OutputNode [thunkTy] [("source", "analyseDecl")])) wire <- compileKernBox parent (show input) (src, tgt) cty @@ -876,7 +876,7 @@ compileModule venv moduleNode = do funcReturning outs = PolyFuncType [] (FunctionType [] outs bratExts) compileNoun :: [HugrType] -> [OutPort] -> Container -> Compile () -compileNoun outs srcPorts H.Ctr {parent, input, output} = do +compileNoun outs srcPorts Ctr {parent, input, output} = do setOp input (OpIn (InputNode [] [("source", "compileNoun")])) setOp output (OpOut (OutputNode outs [("source", "compileNoun")])) for_ (zip [0..] srcPorts) (\(outport, Ex src srcPort) -> diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 40b194d1..f97b6961 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Data.HugrGraph(NodeId, PortId(..), Container(..), - Hugr, -- do NOT export contents, keep abstract + HugrGraph, -- do NOT export contents, keep abstract newWithIO, newModule, splitNamespace, freshNode, freshNodeWithIO, setFirstChildren, @@ -12,8 +12,7 @@ module Data.HugrGraph(NodeId, PortId(..), Container(..), import Brat.Naming import Bwd -import Data.Hugr hiding (Hugr) -import qualified Data.Hugr as D +import Data.Hugr import Data.Bifunctor (first) import Data.Maybe (fromMaybe) @@ -27,7 +26,7 @@ data Container = Ctr { output :: NodeId } -data Hugr = HugrGraph { +data HugrGraph = HugrGraph { root :: NodeId, parents :: M.Map NodeId NodeId, -- definitive list of (valid) nodes, excluding root io_children:: M.Map NodeId (NodeId, NodeId), @@ -37,11 +36,11 @@ data Hugr = HugrGraph { nameSupply :: Namespace } deriving (Eq, Show) -- we probably want a better `show` -splitNamespace :: Hugr -> String -> (Namespace, Hugr) +splitNamespace :: HugrGraph -> String -> (Namespace, HugrGraph) splitNamespace hugr n = let (nsx, nsNew) = split n (nameSupply hugr) in (nsx, hugr {nameSupply = nsNew}) -freshNode :: Hugr -> NodeId -> String -> (NodeId, Hugr) +freshNode :: HugrGraph -> NodeId -> String -> (NodeId, HugrGraph) freshNode hugr@(HugrGraph {root, parents, nameSupply}) parent nam = case M.lookup parent parents of Nothing | parent /= root-> error "parent does not exist" @@ -51,7 +50,7 @@ freshNode hugr@(HugrGraph {root, parents, nameSupply}) parent nam = parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents }) -freshNodeWithIO :: Hugr -> NodeId -> String -> (Container, Hugr) +freshNodeWithIO :: HugrGraph -> NodeId -> String -> (Container, HugrGraph) freshNodeWithIO h gparent desc = let (parent, h2) = freshNode h gparent desc (input, h3) = freshNode h2 parent (desc ++ "_Input") @@ -60,10 +59,10 @@ freshNodeWithIO h gparent desc = -- This is a hack to deal with Conditionals, whose cases must be ordered. -- For now it only works if there are exactly two cases... -setFirstChildren :: Hugr -> NodeId -> [NodeId] -> Hugr +setFirstChildren :: HugrGraph -> NodeId -> [NodeId] -> HugrGraph setFirstChildren h p [c1,c2] = h {io_children = M.alter (\Nothing -> Just (c1,c2)) p (io_children h)} -setOp :: Hugr -> NodeId -> HugrOp -> Hugr +setOp :: HugrGraph -> NodeId -> HugrOp -> HugrGraph -- Insist the parent exists setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of Nothing -> error "name has no parent" @@ -71,7 +70,7 @@ setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of -- alter + partial match is just to fail if key already present h { nodes = M.alter (\Nothing -> Just op) name nodes } -newWithIO :: Namespace -> String -> HugrOp -> (Hugr, Container) +newWithIO :: Namespace -> String -> HugrOp -> (HugrGraph, Container) newWithIO ns nam op = let (name, ns1) = fresh nam ns (inp, ns2) = fresh (nam ++ "_Input") ns1 @@ -89,7 +88,7 @@ newWithIO ns nam op = ,Ctr {parent=root, input, output} ) -newModule :: Namespace -> String -> (Hugr, NodeId) +newModule :: Namespace -> String -> (HugrGraph, NodeId) newModule ns nam = let (name, ns') = fresh nam ns root = NodeId name @@ -105,7 +104,7 @@ newModule ns nam = , root ) -addEdge :: Hugr -> (PortId NodeId, PortId NodeId) -> Hugr +addEdge :: HugrGraph -> (PortId NodeId, PortId NodeId) -> HugrGraph addEdge h@HugrGraph {..} (src@(Port s o), tgt@(Port t i)) = case (M.lookup s nodes, M.lookup t nodes) of (Just _, Just _) -> h { edges_out = addToMap s (o, tgt) edges_out, @@ -116,26 +115,26 @@ addEdge h@HugrGraph {..} (src@(Port s o), tgt@(Port t i)) = case (M.lookup s nod addToMap :: Ord k => k -> v -> M.Map k [v] -> M.Map k [v] addToMap k v m = M.insert k (v:(fromMaybe [] $ M.lookup k m)) m -addOrderEdge :: Hugr -> (NodeId, NodeId) -> Hugr +addOrderEdge :: HugrGraph -> (NodeId, NodeId) -> HugrGraph addOrderEdge h (src, tgt) = addEdge h (Port src orderEdgeOffset, Port tgt orderEdgeOffset) -edgeList :: Hugr -> [(PortId NodeId, PortId NodeId)] +edgeList :: HugrGraph -> [(PortId NodeId, PortId NodeId)] edgeList (HugrGraph {edges_out}) = [(Port n off, tgt) | (n, vs) <- M.assocs edges_out , (off, tgt) <- vs ] -getParent :: Hugr -> NodeId -> NodeId +getParent :: HugrGraph -> NodeId -> NodeId getParent HugrGraph {parents} n = parents M.! n -getOp :: Hugr -> NodeId -> HugrOp +getOp :: HugrGraph -> NodeId -> HugrOp getOp HugrGraph {nodes} n = nodes M.! n -- this should be local to serialize but local `type` is not allowed type StackAndIndices = (Bwd (NodeId, HugrOp) -- node is index, this is (parent, op) , M.Map NodeId Int) -serialize :: Hugr -> D.Hugr Int -serialize hugr@(HugrGraph {root, nodes, parents}) = D.Hugr ( +serialize :: HugrGraph -> Hugr Int +serialize hugr@(HugrGraph {root, nodes, parents}) = Hugr ( (first transNode) <$> (fst nodeStackAndIndices) <>> [], [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] ) where From c2cee45977c111638b02cfd274d2e391c0efecaa Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 19 Dec 2025 21:45:32 +0000 Subject: [PATCH 026/149] Remove HugrGraph.freshNodeWithIO --- brat/Brat/Compile/Hugr.hs | 8 +++++--- brat/Data/HugrGraph.hs | 9 +-------- 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 062d3c34..fad016a3 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -96,10 +96,12 @@ freshNode name parent = do freshNodeWithIO :: String -> NodeId -> Compile Container freshNodeWithIO name parent = do + ctr <- freshNode name parent + input <- freshNode (name ++ "_Input") ctr + output <- freshNode (name ++ "_Input") ctr s <- get - let (ctr, h) = H.freshNodeWithIO (hugr s) parent name - put s {hugr = h} - pure ctr + put s {hugr = H.setFirstChildren (hugr s) ctr [input, output]} + pure $ Ctr ctr input output addEdge :: (PortId NodeId, PortId NodeId) -> Compile () addEdge e = get >>= \st -> put (st { hugr = H.addEdge (hugr st) e }) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index f97b6961..f3c62088 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -2,7 +2,7 @@ module Data.HugrGraph(NodeId, PortId(..), Container(..), HugrGraph, -- do NOT export contents, keep abstract newWithIO, newModule, splitNamespace, - freshNode, freshNodeWithIO, + freshNode, setFirstChildren, setOp, getParent, getOp, addEdge, addOrderEdge, @@ -50,13 +50,6 @@ freshNode hugr@(HugrGraph {root, parents, nameSupply}) parent nam = parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents }) -freshNodeWithIO :: HugrGraph -> NodeId -> String -> (Container, HugrGraph) -freshNodeWithIO h gparent desc = - let (parent, h2) = freshNode h gparent desc - (input, h3) = freshNode h2 parent (desc ++ "_Input") - (output, h4) = freshNode h3 parent (desc ++ "_Output") - in (Ctr {parent, input, output}, h4 {io_children = M.insert parent (input, output) (io_children h4) }) - -- This is a hack to deal with Conditionals, whose cases must be ordered. -- For now it only works if there are exactly two cases... setFirstChildren :: HugrGraph -> NodeId -> [NodeId] -> HugrGraph From cf5f7053564cb0d7003178a2916785a5e4dfbbdd Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 19 Dec 2025 22:18:38 +0000 Subject: [PATCH 027/149] Move Container from HugrGraph to Compile/Hugr --- brat/Brat/Compile/Hugr.hs | 57 ++++++++++++++++++++++++--------------- brat/Data/HugrGraph.hs | 34 ++++------------------- 2 files changed, 40 insertions(+), 51 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index fad016a3..98a908ab 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -24,7 +24,7 @@ import Brat.Syntax.Value import Bwd import Control.Monad.Freer import Data.Hugr -import Data.HugrGraph (HugrGraph, Container(..), NodeId) +import Data.HugrGraph (HugrGraph, NodeId) import qualified Data.HugrGraph as H import Hasochism @@ -69,6 +69,12 @@ data CompilationState = CompilationState , decls :: M.Map Name (NodeId, Bool) } +data Container = Ctr { + parent :: NodeId, + input :: NodeId, + output :: NodeId +} + makeCS :: (Graph, CaptureSets, Store) -> HugrGraph -> CompilationState makeCS (g, cs, store) hugr = CompilationState @@ -94,14 +100,18 @@ freshNode name parent = do put s {hugr = h} pure id +makeIO :: String -> NodeId -> Compile Container +makeIO name parent = do + input <- freshNode (name ++ "_Input") parent + output <- freshNode (name ++ "_Input") parent + s <- get + put s {hugr = H.setFirstChildren (hugr s) parent [input, output]} + pure $ Ctr {parent, input, output} + freshNodeWithIO :: String -> NodeId -> Compile Container freshNodeWithIO name parent = do - ctr <- freshNode name parent - input <- freshNode (name ++ "_Input") ctr - output <- freshNode (name ++ "_Input") ctr - s <- get - put s {hugr = H.setFirstChildren (hugr s) ctr [input, output]} - pure $ Ctr ctr input output + root <- freshNode name parent + makeIO name root addEdge :: (PortId NodeId, PortId NodeId) -> Compile () addEdge e = get >>= \st -> put (st { hugr = H.addEdge (hugr st) e }) @@ -272,8 +282,7 @@ compileClauses parent ins ((matchData, rhs) :| clauses) = do didMatch :: [HugrType] -> NodeId -> [TypedPort] -> Compile [TypedPort] didMatch outTys parent ins = gets bratGraph >>= \(ns,_) -> case ns M.! rhs of BratNode (Box src tgt) _ _ -> do - ctr <- freshNodeWithIO "DidMatch" parent - let dfgId = H.parent ctr + ctr@Ctr {parent=dfgId} <- freshNodeWithIO "DidMatch" parent setOp dfgId (OpDFG (DFG (FunctionType (snd <$> ins) outTys bratExts) [])) compileBox ctr (src, tgt) for_ (zip (fst <$> ins) (Port dfgId <$> [0..])) addEdge @@ -407,12 +416,13 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case let [(_, VFun Braty cty)] = outs boxSig@(inputTys, outputTys) <- compileSig Braty cty let boxFunTy = FunctionType inputTys outputTys bratExts - ((Port loadConst _, _ty), ()) <- compileConstDfg parent n boxSig $ \ctr -> do - setOp (H.input ctr) (OpIn (InputNode inputTys [("source", "Prim")])) - let ins = zip (Port (H.input ctr) <$> [0..]) inputTys - outs <- addNodeWithInputs n (H.parent ctr, OpCustom (CustomOp ext op boxFunTy [])) ins outputTys - setOp (H.output ctr) (OpOut (OutputNode outputTys [("source", "Prim")])) - for_ (zip (fst <$> outs) (Port (H.output ctr) <$> [0..])) addEdge + ((Port loadConst _, _ty), ()) <- compileConstDfg parent n boxSig $ + \Ctr{parent, input, output} -> do + setOp input (OpIn (InputNode inputTys [("source", "Prim")])) + let ins = zip (Port input <$> [0..]) inputTys + outs <- addNodeWithInputs n (parent, OpCustom (CustomOp ext op boxFunTy [])) ins outputTys + setOp output (OpOut (OutputNode outputTys [("source", "Prim")])) + for_ (zip (fst <$> outs) (Port output <$> [0..])) addEdge pure () pure $ default_edges loadConst @@ -535,8 +545,10 @@ compileConstDfg parent desc (inTys, outTys) contents = do let (nsx, hugr') = H.splitNamespace (hugr s) desc put s {hugr=hugr'} -- And pass that namespace into nested monad that compiles the DFG - let (h, ctr) = H.newWithIO nsx ("Box_" ++ show desc) (OpDFG $ DFG funTy []) - let (a, compState) = runState (contents ctr) (makeCS (g,cs,st) h) + let boxdesc = "Box_" ++ desc + let (h, root) = H.new nsx boxdesc (OpDFG $ DFG funTy []) + let (a, compState) = runState (makeIO boxdesc root >>= contents) + (makeCS (g,cs,st) h) let nestedHugr = renameAndSortHugr (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy @@ -561,8 +573,9 @@ compileBratBox parent name (venv, src, tgt) cty = do let allInputTys = parmTys ++ inputTys let boxInnerSig = FunctionType allInputTys outputTys bratExts - (templatePort, _) <- compileConstDfg parent ("BB" ++ show name) (allInputTys, outputTys) $ \ctr -> do - let src_id = H.input ctr -- would be good to name "LiftedCapturedInputs" + (templatePort, _) <- compileConstDfg parent ("BB" ++ show name) (allInputTys, outputTys) $ + -- ideally would name the Input "LiftedCapturedInputs" + \Ctr {parent, input = src_id, output} -> do setOp src_id (OpIn (InputNode allInputTys [("source", "compileBratBox")])) -- Now map ports in the BRAT Graph to their Hugr equivalents. -- Each captured value is read from an element of src_id, starting from 0 @@ -572,7 +585,7 @@ compileBratBox parent name (venv, src, tgt) cty = do st <- get put $ st {liftedOutPorts = M.fromList lifted} -- no need to return any holes - compileTarget (H.parent ctr) (H.output ctr) tgt + compileTarget parent output tgt -- Finally, we add a `Partial` node to supply the captured params. partialNode <- addNode "Partial" (parent, OpCustom $ partialOp boxInnerSig (length params)) @@ -855,7 +868,7 @@ compileModule venv moduleNode = do -- computation that produces this constant. We do so by making a FuncDefn -- that takes no arguments and produces the constant kernel graph value. thunkTy <- HTFunc . PolyFuncType [] . (\(ins, outs) -> FunctionType ins outs bratExts) <$> compileSig Kerny cty - pure (funcReturning [thunkTy], True, \Ctr {parent,input,output} -> do + pure (funcReturning [thunkTy], True, \Ctr {parent, input, output} -> do setOp input (OpIn (InputNode [] [("source", "analyseDecl")])) setOp output (OpOut (OutputNode [thunkTy] [("source", "analyseDecl")])) wire <- compileKernBox parent (show input) (src, tgt) cty @@ -894,7 +907,7 @@ compile :: Store -> VEnv -> BS.ByteString compile store ns g capSets venv = - let (hugr, moduleNode) = H.newModule ns "module" + let (hugr, moduleNode) = H.new ns "module" (OpMod ModuleOp) in evalState (trackM "compileFunctions" *> compileModule venv moduleNode *> diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index f3c62088..a7463756 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -module Data.HugrGraph(NodeId, PortId(..), Container(..), +module Data.HugrGraph(NodeId, PortId(..), HugrGraph, -- do NOT export contents, keep abstract - newWithIO, newModule, splitNamespace, + new, splitNamespace, freshNode, setFirstChildren, setOp, getParent, getOp, @@ -20,12 +20,6 @@ import qualified Data.Map as M newtype NodeId = NodeId Name deriving (Eq, Ord, Show) -data Container = Ctr { - parent :: NodeId, - input :: NodeId, - output :: NodeId -} - data HugrGraph = HugrGraph { root :: NodeId, parents :: M.Map NodeId NodeId, -- definitive list of (valid) nodes, excluding root @@ -63,33 +57,15 @@ setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of -- alter + partial match is just to fail if key already present h { nodes = M.alter (\Nothing -> Just op) name nodes } -newWithIO :: Namespace -> String -> HugrOp -> (HugrGraph, Container) -newWithIO ns nam op = - let (name, ns1) = fresh nam ns - (inp, ns2) = fresh (nam ++ "_Input") ns1 - (outp, ns3) = fresh (nam ++ "_Output") ns2 - (root, input, output) = (NodeId name, NodeId inp, NodeId outp) - in (HugrGraph { - root, - parents = M.fromList ((, root) <$> [input, output]), - io_children = M.singleton root (input, output), - nodes = M.singleton root op, - edges_in = M.empty, - edges_out = M.empty, - nameSupply = ns3 - } - ,Ctr {parent=root, input, output} - ) - -newModule :: Namespace -> String -> (HugrGraph, NodeId) -newModule ns nam = +new :: Namespace -> String -> HugrOp -> (HugrGraph, NodeId) +new ns nam op = let (name, ns') = fresh nam ns root = NodeId name in (HugrGraph { root, parents = M.empty, io_children = M.empty, - nodes = M.singleton root (OpMod ModuleOp), + nodes = M.singleton root op, edges_in = M.empty, edges_out = M.empty, nameSupply = ns' From c50cbb7326be95d1a6b8c197850ed2039fecc524 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 19 Dec 2025 22:52:08 +0000 Subject: [PATCH 028/149] new returns just HugrGraph, expose root accessor --- brat/Brat/Compile/Hugr.hs | 12 ++++++------ brat/Data/HugrGraph.hs | 8 +++----- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 98a908ab..1d61c84e 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -15,7 +15,7 @@ import Brat.Checker.Helpers (binderToValue) import Brat.Checker.Types (Store(..), VEnv) import Brat.Eval (eval, evalCTy, kindType) import Brat.Graph hiding (lookupNode) -import Brat.Naming +import Brat.Naming hiding (root) import Brat.QualName import Brat.Syntax.Port import Brat.Syntax.Common @@ -24,7 +24,7 @@ import Brat.Syntax.Value import Bwd import Control.Monad.Freer import Data.Hugr -import Data.HugrGraph (HugrGraph, NodeId) +import Data.HugrGraph (HugrGraph(..), NodeId) import qualified Data.HugrGraph as H import Hasochism @@ -546,8 +546,8 @@ compileConstDfg parent desc (inTys, outTys) contents = do put s {hugr=hugr'} -- And pass that namespace into nested monad that compiles the DFG let boxdesc = "Box_" ++ desc - let (h, root) = H.new nsx boxdesc (OpDFG $ DFG funTy []) - let (a, compState) = runState (makeIO boxdesc root >>= contents) + let h = H.new nsx boxdesc (OpDFG $ DFG funTy []) + let (a, compState) = runState (makeIO boxdesc (root h) >>= contents) (makeCS (g,cs,st) h) let nestedHugr = renameAndSortHugr (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy @@ -907,10 +907,10 @@ compile :: Store -> VEnv -> BS.ByteString compile store ns g capSets venv = - let (hugr, moduleNode) = H.new ns "module" (OpMod ModuleOp) + let hugr = H.new ns "module" (OpMod ModuleOp) in evalState (trackM "compileFunctions" *> - compileModule venv moduleNode *> + compileModule venv (root hugr) *> trackM "dumpJSON" *> dumpJSON ) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index a7463756..5d00c6ed 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Data.HugrGraph(NodeId, PortId(..), - HugrGraph, -- do NOT export contents, keep abstract + HugrGraph(root), -- do NOT export contents, keep abstract new, splitNamespace, freshNode, setFirstChildren, @@ -57,11 +57,11 @@ setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of -- alter + partial match is just to fail if key already present h { nodes = M.alter (\Nothing -> Just op) name nodes } -new :: Namespace -> String -> HugrOp -> (HugrGraph, NodeId) +new :: Namespace -> String -> HugrOp -> HugrGraph new ns nam op = let (name, ns') = fresh nam ns root = NodeId name - in (HugrGraph { + in HugrGraph { root, parents = M.empty, io_children = M.empty, @@ -70,8 +70,6 @@ new ns nam op = edges_out = M.empty, nameSupply = ns' } - , root - ) addEdge :: HugrGraph -> (PortId NodeId, PortId NodeId) -> HugrGraph addEdge h@HugrGraph {..} (src@(Port s o), tgt@(Port t i)) = case (M.lookup s nodes, M.lookup t nodes) of From 3f3c06d858d50ae65e999ee52d874348c5279a44 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 19 Dec 2025 22:54:54 +0000 Subject: [PATCH 029/149] io_children->first_children stores any number --- brat/Data/HugrGraph.hs | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 5d00c6ed..2caa8668 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -23,7 +23,7 @@ newtype NodeId = NodeId Name deriving (Eq, Ord, Show) data HugrGraph = HugrGraph { root :: NodeId, parents :: M.Map NodeId NodeId, -- definitive list of (valid) nodes, excluding root - io_children:: M.Map NodeId (NodeId, NodeId), + first_children:: M.Map NodeId [NodeId], nodes :: M.Map NodeId HugrOp, edges_out :: M.Map NodeId [(Int, PortId NodeId)], edges_in :: M.Map NodeId [(PortId NodeId, Int)], @@ -44,10 +44,8 @@ freshNode hugr@(HugrGraph {root, parents, nameSupply}) parent nam = parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents }) --- This is a hack to deal with Conditionals, whose cases must be ordered. --- For now it only works if there are exactly two cases... setFirstChildren :: HugrGraph -> NodeId -> [NodeId] -> HugrGraph -setFirstChildren h p [c1,c2] = h {io_children = M.alter (\Nothing -> Just (c1,c2)) p (io_children h)} +setFirstChildren h p cs = h {first_children = M.alter (\Nothing -> Just cs) p (first_children h)} setOp :: HugrGraph -> NodeId -> HugrOp -> HugrGraph -- Insist the parent exists @@ -64,7 +62,7 @@ new ns nam op = in HugrGraph { root, parents = M.empty, - io_children = M.empty, + first_children = M.empty, nodes = M.singleton root op, edges_in = M.empty, edges_out = M.empty, @@ -118,12 +116,11 @@ serialize hugr@(HugrGraph {root, nodes, parents}) = Hugr ( parent = parents M.! n -- guaranteed as root is always in `ins` with_parent@(stack, indices) = addNode ins parent -- add parent first, will recurse up in case M.lookup n indices of - Just _ -> with_parent -- self added by recursive call; we must be in parent's io_children + Just _ -> with_parent -- self added by recursive call; we must be in parent's first_children Nothing -> let with_n = (stack :< (parent, nodes M.! n), M.insert n (M.size indices) indices) - in case M.lookup n (io_children hugr) of - -- finally add io_children immediately after - (Just (inp, out)) -> addNode (addNode with_n inp) out - Nothing -> with_n + chs = fromMaybe [] (M.lookup n (first_children hugr)) + -- finally add first_children immediately after parent + in foldl addNode with_n chs transNode :: NodeId -> Int transNode = ((snd nodeStackAndIndices) M.!) From 365dddc56e0e3a5b527b06067f9d2d3076d9dc81 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 20 Dec 2025 09:23:40 +0000 Subject: [PATCH 030/149] ake HugrGraph ops in State HugrGraph, Compile use onHugr --- brat/Brat/Compile/Hugr.hs | 33 ++++++++++++------------------ brat/Data/HugrGraph.hs | 43 +++++++++++++++++++++------------------ 2 files changed, 36 insertions(+), 40 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 1d61c84e..84c4f442 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -69,6 +69,11 @@ data CompilationState = CompilationState , decls :: M.Map Name (NodeId, Bool) } +type Compile = State CompilationState + +onHugr :: State HugrGraph a -> Compile a +onHugr f = get >>= \s -> let (r, h') = runState f (hugr s) in put (s {hugr=h'}) >> pure r + data Container = Ctr { parent :: NodeId, input :: NodeId, @@ -94,27 +99,20 @@ registerFuncDef name hugrDef = do put (st { decls = M.insert name hugrDef (decls st) }) freshNode :: String -> NodeId -> Compile NodeId -freshNode name parent = do - s <- get - let (id, h) = H.freshNode (hugr s) parent name - put s {hugr = h} - pure id +freshNode name parent = onHugr (H.freshNode parent name) makeIO :: String -> NodeId -> Compile Container makeIO name parent = do input <- freshNode (name ++ "_Input") parent output <- freshNode (name ++ "_Input") parent - s <- get - put s {hugr = H.setFirstChildren (hugr s) parent [input, output]} + onHugr $ H.setFirstChildren parent [input, output] pure $ Ctr {parent, input, output} freshNodeWithIO :: String -> NodeId -> Compile Container -freshNodeWithIO name parent = do - root <- freshNode name parent - makeIO name root +freshNodeWithIO name parent = freshNode name parent >>= makeIO name addEdge :: (PortId NodeId, PortId NodeId) -> Compile () -addEdge e = get >>= \st -> put (st { hugr = H.addEdge (hugr st) e }) +addEdge e = onHugr (H.addEdge e) addNode :: String -> (NodeId, HugrOp) -> Compile NodeId addNode nam (parent, op) = do @@ -122,8 +120,6 @@ addNode nam (parent, op) = do setOp name (addMetadata [("id", show name)] op) pure name -type Compile = State CompilationState - runCheckingInCompile :: Free CheckingSig t -> Compile t runCheckingInCompile (Ret t) = pure t runCheckingInCompile (Req (ELup e) k) = do @@ -177,7 +173,7 @@ compilePorts = compileGraphTypes . map snd setOp :: NodeId -> HugrOp -> Compile () setOp name op | track ("addOp " ++ show op ++ show name) False = undefined -setOp name op = get >>= \st -> put (st { hugr = H.setOp (hugr st) name op }) +setOp name op = onHugr (H.setOp name op) registerCompiled :: Name -> NodeId -> Compile () registerCompiled from to | track (show from ++ " |-> " ++ show to) False = undefined @@ -222,7 +218,7 @@ compileArithNode parent op TFloat = addNode (show op ++ "_Float") (parent, OpCus compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty renameAndSortHugr :: HugrGraph -> Hugr Int -renameAndSortHugr hugr = H.serialize (foldl H.addOrderEdge hugr orderEdges) +renameAndSortHugr hugr = H.serialize (execState (for_ orderEdges H.addOrderEdge) hugr) where orderEdges :: [(NodeId, NodeId)] orderEdges = @@ -541,9 +537,7 @@ compileConstDfg parent desc (inTys, outTys) contents = do cs <- gets capSets let funTy = FunctionType inTys outTys bratExts -- First, we fork off a new namespace - s <- get - let (nsx, hugr') = H.splitNamespace (hugr s) desc - put s {hugr=hugr'} + nsx <- onHugr (H.splitNamespace desc) -- And pass that namespace into nested monad that compiles the DFG let boxdesc = "Box_" ++ desc let h = H.new nsx boxdesc (OpDFG $ DFG funTy []) @@ -750,8 +744,7 @@ makeConditional lbl parent discrim otherInputs cases = do else (error "Conditional output types didn't match") let condOp = OpConditional (Conditional rows (snd <$> otherInputs) outTys [("label", lbl)]) setOp condId condOp - s <- get - put s {hugr = H.setFirstChildren (hugr s) condId (snd <$> outTyss_cases)} + onHugr $ H.setFirstChildren condId (snd <$> outTyss_cases) addEdge (fst discrim, Port condId 0) traverse_ addEdge (zip (fst <$> otherInputs) (Port condId <$> [1..])) pure $ zip (Port condId <$> [0..]) outTys diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 2caa8668..b8be9c77 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -10,10 +10,11 @@ module Data.HugrGraph(NodeId, PortId(..), ) where import Brat.Naming - import Bwd import Data.Hugr +import Control.Monad.State (State, state) + import Data.Bifunctor (first) import Data.Maybe (fromMaybe) import qualified Data.Map as M @@ -30,12 +31,12 @@ data HugrGraph = HugrGraph { nameSupply :: Namespace } deriving (Eq, Show) -- we probably want a better `show` -splitNamespace :: HugrGraph -> String -> (Namespace, HugrGraph) -splitNamespace hugr n = let (nsx, nsNew) = split n (nameSupply hugr) - in (nsx, hugr {nameSupply = nsNew}) +splitNamespace :: String -> State HugrGraph Namespace +splitNamespace n = state $ \hugr -> let (nsx, nsNew) = split n (nameSupply hugr) + in (nsx, hugr {nameSupply = nsNew}) -freshNode :: HugrGraph -> NodeId -> String -> (NodeId, HugrGraph) -freshNode hugr@(HugrGraph {root, parents, nameSupply}) parent nam = +freshNode :: NodeId -> String -> State HugrGraph NodeId +freshNode parent nam = state $ \hugr@(HugrGraph {root, parents, nameSupply}) -> case M.lookup parent parents of Nothing | parent /= root-> error "parent does not exist" _ -> let (freshName, newSupply) = fresh nam nameSupply @@ -44,16 +45,17 @@ freshNode hugr@(HugrGraph {root, parents, nameSupply}) parent nam = parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents }) -setFirstChildren :: HugrGraph -> NodeId -> [NodeId] -> HugrGraph -setFirstChildren h p cs = h {first_children = M.alter (\Nothing -> Just cs) p (first_children h)} +setFirstChildren :: NodeId -> [NodeId] -> State HugrGraph () +setFirstChildren p cs = state $ \h -> let nch = M.alter (\Nothing -> Just cs) p (first_children h) + in ((), h {first_children = nch}) -setOp :: HugrGraph -> NodeId -> HugrOp -> HugrGraph +setOp :: NodeId -> HugrOp -> State HugrGraph () -- Insist the parent exists -setOp h@HugrGraph {parents, nodes} name op = case M.lookup name parents of +setOp name op = state $ \h@HugrGraph {parents, nodes} -> case M.lookup name parents of Nothing -> error "name has no parent" Just _ -> -- alter + partial match is just to fail if key already present - h { nodes = M.alter (\Nothing -> Just op) name nodes } + ((), h { nodes = M.alter (\Nothing -> Just op) name nodes }) new :: Namespace -> String -> HugrOp -> HugrGraph new ns nam op = @@ -69,19 +71,20 @@ new ns nam op = nameSupply = ns' } -addEdge :: HugrGraph -> (PortId NodeId, PortId NodeId) -> HugrGraph -addEdge h@HugrGraph {..} (src@(Port s o), tgt@(Port t i)) = case (M.lookup s nodes, M.lookup t nodes) of - (Just _, Just _) -> h { - edges_out = addToMap s (o, tgt) edges_out, - edges_in = addToMap t (src, i) edges_in - } - _ -> error "addEdge to/from node not present" +addEdge :: (PortId NodeId, PortId NodeId) -> State HugrGraph () +addEdge (src@(Port s o), tgt@(Port t i)) = state $ \h@HugrGraph {..} -> + ((), ) $ case (M.lookup s nodes, M.lookup t nodes) of + (Just _, Just _) -> h { + edges_out = addToMap s (o, tgt) edges_out, + edges_in = addToMap t (src, i) edges_in + } + _ -> error "addEdge to/from node not present" where addToMap :: Ord k => k -> v -> M.Map k [v] -> M.Map k [v] addToMap k v m = M.insert k (v:(fromMaybe [] $ M.lookup k m)) m -addOrderEdge :: HugrGraph -> (NodeId, NodeId) -> HugrGraph -addOrderEdge h (src, tgt) = addEdge h (Port src orderEdgeOffset, Port tgt orderEdgeOffset) +addOrderEdge :: (NodeId, NodeId) -> State HugrGraph () +addOrderEdge (src, tgt) = addEdge (Port src orderEdgeOffset, Port tgt orderEdgeOffset) edgeList :: HugrGraph -> [(PortId NodeId, PortId NodeId)] edgeList (HugrGraph {edges_out}) = [(Port n off, tgt) | (n, vs) <- M.assocs edges_out From cb31461cd0607d4172c8e0d1a7d3d83c3a7d886b Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 22 Dec 2025 17:46:19 +0000 Subject: [PATCH 031/149] HugrGraph.hs: do not re-export PortId --- brat/Data/HugrGraph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index b8be9c77..274259ab 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Data.HugrGraph(NodeId, PortId(..), +module Data.HugrGraph(NodeId, HugrGraph(root), -- do NOT export contents, keep abstract new, splitNamespace, freshNode, From b88878a3bf87fba10c0686ac5e6f288300907fe1 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 22 Dec 2025 18:19:45 +0000 Subject: [PATCH 032/149] reduce imports from Naming --- brat/Data/HugrGraph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 274259ab..ddb640e7 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -9,7 +9,7 @@ module Data.HugrGraph(NodeId, edgeList, serialize ) where -import Brat.Naming +import Brat.Naming (Namespace, Name, fresh, split) import Bwd import Data.Hugr From 446d97850d0f6cb3e4c508fdfbd0a62d2d2fcbe6 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 22 Dec 2025 21:07:39 +0000 Subject: [PATCH 033/149] Move renameAndSort inside serialize --- brat/Brat/Compile/Hugr.hs | 31 ++--------------------------- brat/Data/HugrGraph.hs | 42 +++++++++++++++++++++++++++++++++------ 2 files changed, 38 insertions(+), 35 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 84c4f442..2bd81ec4 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -217,35 +217,8 @@ compileArithNode parent op TFloat = addNode (show op ++ "_Float") (parent, OpCus ) compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty -renameAndSortHugr :: HugrGraph -> Hugr Int -renameAndSortHugr hugr = H.serialize (execState (for_ orderEdges H.addOrderEdge) hugr) - where - orderEdges :: [(NodeId, NodeId)] - orderEdges = - -- Nonlocal edges (from a node to another which is a *descendant* of a sibling of the source) - -- require an extra order edge from the source to the sibling that is ancestor of the target - let interEdges = [(n1, n2) | (Port n1 _, Port n2 _) <- H.edgeList hugr, - (parentOf n1 /= parentOf n2), - requiresOrderEdge (H.getOp hugr n1), - requiresOrderEdge (H.getOp hugr n2)] in - track ("interEdges: " ++ show interEdges) (walkUp <$> interEdges) - - requiresOrderEdge :: HugrOp -> Bool - requiresOrderEdge (OpMod _) = False - requiresOrderEdge (OpDefn _) = False - requiresOrderEdge (OpConst _) = False - requiresOrderEdge _ = True - - parentOf = H.getParent hugr - - -- Walk up the hierarchy from the tgt until we hit a node at the same level as src - walkUp :: (NodeId, NodeId) -> (NodeId, NodeId) - walkUp (src, tgt) | parentOf src == parentOf tgt = (src, tgt) - walkUp (_, tgt) | parentOf tgt == tgt = error "Tgt was not descendant of Src-parent" - walkUp (src, tgt) = walkUp (src, parentOf tgt) - dumpJSON :: Compile BS.ByteString -dumpJSON = gets hugr <&> (encode . renameAndSortHugr) +dumpJSON = gets hugr <&> (encode . H.serialize) compileClauses :: NodeId -> [TypedPort] -> NonEmpty (TestMatchData m, Name) -> Compile [TypedPort] compileClauses parent ins ((matchData, rhs) :| clauses) = do @@ -543,7 +516,7 @@ compileConstDfg parent desc (inTys, outTys) contents = do let h = H.new nsx boxdesc (OpDFG $ DFG funTy []) let (a, compState) = runState (makeIO boxdesc (root h) >>= contents) (makeCS (g,cs,st) h) - let nestedHugr = renameAndSortHugr (hugr compState) + let nestedHugr = H.serialize (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy constNode <- addNode ("ConstTemplate_" ++ desc) (parent, OpConst (ConstOp (HVFunction nestedHugr))) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index ddb640e7..ef8f37ae 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -11,14 +11,16 @@ module Data.HugrGraph(NodeId, import Brat.Naming (Namespace, Name, fresh, split) import Bwd -import Data.Hugr - -import Control.Monad.State (State, state) +import Data.Hugr hiding (const) +import Control.Monad.State (State, execState, state) +import Data.Foldable (for_) import Data.Bifunctor (first) import Data.Maybe (fromMaybe) import qualified Data.Map as M +track = const id + newtype NodeId = NodeId Name deriving (Eq, Ord, Show) data HugrGraph = HugrGraph { @@ -97,12 +99,40 @@ getParent HugrGraph {parents} n = parents M.! n getOp :: HugrGraph -> NodeId -> HugrOp getOp HugrGraph {nodes} n = nodes M.! n --- this should be local to serialize but local `type` is not allowed +serialize :: HugrGraph -> Hugr Int +serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) + where + orderEdges :: [(NodeId, NodeId)] + orderEdges = + -- Nonlocal edges (from a node to another which is a *descendant* of a sibling of the source) + -- require an extra order edge from the source to the sibling that is ancestor of the target + let interEdges = [(n1, n2) | (Port n1 _, Port n2 _) <- edgeList hugr, + (parentOf n1 /= parentOf n2), + requiresOrderEdge n1, + requiresOrderEdge n2] in + track ("interEdges: " ++ show interEdges) (walkUp <$> interEdges) + + requiresOrderEdge :: NodeId -> Bool + requiresOrderEdge n = case getOp hugr n of + OpMod _ -> False + OpDefn _ -> False + OpConst _ -> False + _ -> True + + parentOf = getParent hugr + + -- Walk up the hierarchy from the tgt until we hit a node at the same level as src + walkUp :: (NodeId, NodeId) -> (NodeId, NodeId) + walkUp (src, tgt) | parentOf src == parentOf tgt = (src, tgt) + walkUp (_, tgt) | parentOf tgt == tgt = error "Tgt was not descendant of Src-parent" + walkUp (src, tgt) = walkUp (src, parentOf tgt) + +-- this should be local to renameAndSort but local `type` is not allowed type StackAndIndices = (Bwd (NodeId, HugrOp) -- node is index, this is (parent, op) , M.Map NodeId Int) -serialize :: HugrGraph -> Hugr Int -serialize hugr@(HugrGraph {root, nodes, parents}) = Hugr ( +renameAndSort :: HugrGraph -> Hugr Int +renameAndSort hugr@(HugrGraph {root, nodes, parents}) = Hugr ( (first transNode) <$> (fst nodeStackAndIndices) <>> [], [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] ) where From cac91fe441ece7dec77a995943111d009a9c0eea Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 22 Dec 2025 21:05:40 +0000 Subject: [PATCH 034/149] Honour first_children of root --- brat/Data/HugrGraph.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index ef8f37ae..383142c3 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -132,15 +132,16 @@ type StackAndIndices = (Bwd (NodeId, HugrOp) -- node is index, this is (parent, , M.Map NodeId Int) renameAndSort :: HugrGraph -> Hugr Int -renameAndSort hugr@(HugrGraph {root, nodes, parents}) = Hugr ( +renameAndSort hugr@(HugrGraph {root, first_children, nodes, parents}) = Hugr ( (first transNode) <$> (fst nodeStackAndIndices) <>> [], [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] ) where - nodeStackAndIndices :: StackAndIndices - nodeStackAndIndices = foldl addNode - (B0 :< (root, nodes M.! root), M.singleton root 0) - (M.keys parents) + nodeStackAndIndices = let just_root = (B0 :< (root, nodes M.! root), M.singleton root 0) + init = case M.lookup root first_children of + Nothing -> just_root + Just fs -> foldl addNode just_root fs + in foldl addNode init (M.keys parents) addNode :: StackAndIndices -> NodeId -> StackAndIndices addNode ins n = case M.lookup n (snd ins) of @@ -151,7 +152,7 @@ renameAndSort hugr@(HugrGraph {root, nodes, parents}) = Hugr ( in case M.lookup n indices of Just _ -> with_parent -- self added by recursive call; we must be in parent's first_children Nothing -> let with_n = (stack :< (parent, nodes M.! n), M.insert n (M.size indices) indices) - chs = fromMaybe [] (M.lookup n (first_children hugr)) + chs = fromMaybe [] (M.lookup n first_children) -- finally add first_children immediately after parent in foldl addNode with_n chs From f05356995828228b66217a307e6564b889956242 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 22 Dec 2025 21:09:23 +0000 Subject: [PATCH 035/149] HugrGraph.rs: add splice --- brat/Data/HugrGraph.hs | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 8f914435..0dd4df9f 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -5,11 +5,11 @@ module Data.HugrGraph(NodeId, freshNode, setFirstChildren, setOp, getParent, getOp, - addEdge, addOrderEdge, - edgeList, serialize + addEdge, addOrderEdge, edgeList, + splice, serialize ) where -import Brat.Naming (Namespace, Name, fresh, split) +import Brat.Naming (Namespace, Name(..), fresh, split) import Bwd import Data.Hugr hiding (const) @@ -99,6 +99,34 @@ getParent HugrGraph {parents} n = parents M.! n getOp :: HugrGraph -> NodeId -> HugrOp getOp HugrGraph {nodes} n = nodes M.! n +--- Replaces the specified node of the first Hugr, with the second Hugr. +splice :: HugrGraph -> NodeId -> HugrGraph -> HugrGraph +splice host hole add = case M.lookup hole (nodes host) of + Just (OpCustom (CustomOp "BRAT" "Hole" sig _)) -> case M.lookup (root add) (nodes add) of + Just (OpDFG (DFG sig' _)) | sig == sig' -> {-inlineDFG hole-} host { + -- prefer host entry for parent of (`hole` == root of `add`) + parents = union (parents host) (M.mapKeys k $ M.map k $ parents add), + -- override host `nodes` for `hole` with new (DFG) + nodes = M.union (M.mapKeys k (nodes add)) (nodes host), + edges_in = union (edges_in host) $ M.fromList [(k tgt, [(Port (k srcNode) srcPort, tgtPort) + | (Port srcNode srcPort, tgtPort) <- in_edges ]) + | (tgt, in_edges ) <- M.assocs (edges_in add)], + edges_out = union (edges_out host) $ M.fromList [(k src, [(srcPort, Port (k tgtNode) tgtPort) + | (srcPort, Port tgtNode tgtPort) <- out_edges]) + | (src, out_edges) <- M.assocs (edges_out add)], + first_children = union (first_children host) (M.mapKeys k $ M.map (k <$>) $ first_children add) + } + where + prefixRoot :: NodeId -> NodeId + prefixRoot (NodeId (MkName ids)) = let NodeId (MkName rs) = hole in NodeId $ MkName (rs ++ ids) + + keyMap :: M.Map NodeId NodeId -- translate `add` keys into `host` by prefixing with `hole`. + -- parent is definitive list of non-root nodes + keyMap = M.fromList $ (root add, hole):[(k, prefixRoot k) | k <- M.keys (parents add)] + + union = M.unionWith (\_ _ -> error "keys not disjoint") + k = (keyMap M.!) + serialize :: HugrGraph -> Hugr Int serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) where From 4b25c84d0012a85e30e2c5f95799695ed9652b44 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 22 Dec 2025 22:35:58 +0000 Subject: [PATCH 036/149] refactor previous --- brat/Data/HugrGraph.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 383142c3..8f914435 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -132,15 +132,14 @@ type StackAndIndices = (Bwd (NodeId, HugrOp) -- node is index, this is (parent, , M.Map NodeId Int) renameAndSort :: HugrGraph -> Hugr Int -renameAndSort hugr@(HugrGraph {root, first_children, nodes, parents}) = Hugr ( +renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr ( (first transNode) <$> (fst nodeStackAndIndices) <>> [], [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] ) where + first_children k = M.findWithDefault [] k fc nodeStackAndIndices :: StackAndIndices nodeStackAndIndices = let just_root = (B0 :< (root, nodes M.! root), M.singleton root 0) - init = case M.lookup root first_children of - Nothing -> just_root - Just fs -> foldl addNode just_root fs + init = foldl addNode just_root (first_children root) in foldl addNode init (M.keys parents) addNode :: StackAndIndices -> NodeId -> StackAndIndices @@ -152,9 +151,8 @@ renameAndSort hugr@(HugrGraph {root, first_children, nodes, parents}) = Hugr ( in case M.lookup n indices of Just _ -> with_parent -- self added by recursive call; we must be in parent's first_children Nothing -> let with_n = (stack :< (parent, nodes M.! n), M.insert n (M.size indices) indices) - chs = fromMaybe [] (M.lookup n first_children) - -- finally add first_children immediately after parent - in foldl addNode with_n chs + -- finally add first_children immediately after n + in foldl addNode with_n (first_children n) transNode :: NodeId -> Int transNode = ((snd nodeStackAndIndices) M.!) From 109cbe2bf051fcd3ac36b1b6df681604c24e3b2d Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 22 Dec 2025 21:06:00 +0000 Subject: [PATCH 037/149] Add test, and some debugging info --- brat/Data/HugrGraph.hs | 2 ++ brat/brat.cabal | 4 ++- brat/test/Main.hs | 3 ++ brat/test/Test/HugrGraph.hs | 65 +++++++++++++++++++++++++++++++++++++ brat/tools/validate.sh | 28 ++++++++-------- 5 files changed, 88 insertions(+), 14 deletions(-) create mode 100644 brat/test/Test/HugrGraph.hs diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 0dd4df9f..84f04ef3 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -116,6 +116,8 @@ splice host hole add = case M.lookup hole (nodes host) of | (src, out_edges) <- M.assocs (edges_out add)], first_children = union (first_children host) (M.mapKeys k $ M.map (k <$>) $ first_children add) } + other -> error $ "Expected DFG with sig " ++ show sig ++ "\nBut found: " ++ show other + other -> error $ "Expected a hole, found " ++ show other where prefixRoot :: NodeId -> NodeId prefixRoot (NodeId (MkName ids)) = let NodeId (MkName rs) = hole in NodeId $ MkName (rs ++ ids) diff --git a/brat/brat.cabal b/brat/brat.cabal index 81e57265..51ad35c3 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -166,6 +166,7 @@ test-suite tests Test.Elaboration, Test.Failure, Test.Graph, + Test.HugrGraph, Test.Libs, Test.Parsing, Test.Naming, @@ -175,7 +176,8 @@ test-suite tests Test.TypeArith, Test.Util - build-depends: base <5, + build-depends: aeson, + base <5, brat, tasty, tasty-hunit, diff --git a/brat/test/Main.hs b/brat/test/Main.hs index 2c67e0cb..f91033f6 100644 --- a/brat/test/Main.hs +++ b/brat/test/Main.hs @@ -7,6 +7,7 @@ import Test.Graph import Test.Compile.Hugr import Test.Elaboration import Test.Failure +import Test.HugrGraph import Test.Libs import Test.Naming import Test.Parsing @@ -64,6 +65,7 @@ main = do parsingTests <- getParsingTests compilationTests <- setupCompilationTests graphTests <- getGraphTests + spliceTests <- getSpliceTests let coroTests = testGroup "coroutine" [testCase "coroT1" $ assertChecking coroT1 ,testCase "coroT2" $ assertCheckingFail "Typechecking blocked on" coroT2 @@ -82,4 +84,5 @@ main = do ,compilationTests ,typeArithTests ,coroTests + ,spliceTests ] diff --git a/brat/test/Test/HugrGraph.hs b/brat/test/Test/HugrGraph.hs new file mode 100644 index 00000000..7cd1688a --- /dev/null +++ b/brat/test/Test/HugrGraph.hs @@ -0,0 +1,65 @@ +module Test.HugrGraph(getSpliceTests) where + +import Brat.Naming as N +import Data.HugrGraph as H +import Data.Hugr + +import Control.Monad.State (State, execState, get, runState) +import Data.Aeson (encode) +import Data.Functor ((<&>)) +import qualified Data.ByteString.Lazy as BS +import System.Directory (createDirectoryIfMissing) +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit + +prefix = "test/hugr" +outputDir = prefix "output" + +addNode :: String -> NodeId -> HugrOp -> State HugrGraph NodeId +addNode nam parent op = do + name <- H.freshNode parent nam + H.setOp name op + pure name + +getSpliceTests :: IO TestTree +getSpliceTests = createDirectoryIfMissing True outputDir >> pure testSplice + +testSplice :: TestTree +testSplice = testCaseInfo "splice" $ do + let (h, holeId) = host + BS.writeFile (outputDir "host.json") (encode $ H.serialize h) + BS.writeFile (outputDir "insertee.json") (encode $ H.serialize dfgHugr) + let resHugr = H.splice h holeId dfgHugr + let outFile = outputDir "result.json" + BS.writeFile outFile (encode $ H.serialize resHugr) + pure $ "Written to " ++ outFile ++ " pending validation" + where + host :: (HugrGraph, NodeId) + host = swap $ flip runState (H.new N.root "root" rootDefn) $ do + root <- get <&> H.root + input <- addNode "inp" root (OpIn (InputNode tys [])) + output <- addNode "out" root (OpOut (OutputNode tys [])) + setFirstChildren root [input, output] + hole <- addNode "hole" root (OpCustom $ holeOp 0 tq_ty) + H.addEdge (Port input 0, Port hole 0) + H.addEdge (Port input 1, Port hole 1) + H.addEdge (Port hole 0, Port output 0) + H.addEdge (Port hole 1, Port output 1) + pure hole + dfgHugr :: HugrGraph + dfgHugr = flip execState (H.new N.root "root" rootDfg) $ do + root <- get <&> H.root + input <- addNode "inp" root (OpIn (InputNode tys [])) + output <- addNode "out" root (OpOut (OutputNode tys [])) + setFirstChildren root [input, output] + gate <- addNode "gate" root (OpCustom $ CustomOp "tket" "CX" tq_ty []) + H.addEdge (Port input 0, Port gate 0) + H.addEdge (Port input 1, Port gate 1) + H.addEdge (Port gate 0, Port output 0) + H.addEdge (Port gate 1, Port output 1) + swap (x,y) = (y,x) + tys = [HTQubit, HTQubit] + tq_ty = FunctionType tys tys bratExts + rootDefn = OpDefn $ FuncDefn "main" (PolyFuncType [] tq_ty) [] + rootDfg = OpDFG $ DFG tq_ty [] diff --git a/brat/tools/validate.sh b/brat/tools/validate.sh index 2a4342a0..e8f234d5 100755 --- a/brat/tools/validate.sh +++ b/brat/tools/validate.sh @@ -12,20 +12,22 @@ declare -a FAILED_TEST_MSGS UNEXPECTED_PASSES= NUM_FAILURES=0 -for json in $(find test/compilation/output -maxdepth 1 -name "*.json"); do - echo Validating "$json" - RESULT=$(cat "$json" | hugr_validator 2>&1) - if [ $? -ne 0 ]; then - FAILED_TEST_NAMES[NUM_FAILURES]=$json - FAILED_TEST_MSGS[NUM_FAILURES]=$RESULT - NUM_FAILURES=$((NUM_FAILURES + 1)) - fi -done +for dir in test/compilation/output test/hugr/output; do + for json in $(find $dir -maxdepth 1 -name "*.json"); do + echo Validating "$json" + RESULT=$(cat "$json" | hugr_validator 2>&1) + if [ $? -ne 0 ]; then + FAILED_TEST_NAMES[NUM_FAILURES]=$json + FAILED_TEST_MSGS[NUM_FAILURES]=$RESULT + NUM_FAILURES=$((NUM_FAILURES + 1)) + fi + done -for invalid_json in $(find test/compilation/output -maxdepth 1 -name "*.json.invalid"); do - if (hugr_validator < $invalid_json 2>/dev/null > /dev/null); then - UNEXPECTED_PASSES="$UNEXPECTED_PASSES $invalid_json" - fi + for invalid_json in $(find test/compilation/output -maxdepth 1 -name "*.json.invalid"); do + if (hugr_validator < $invalid_json 2>/dev/null > /dev/null); then + UNEXPECTED_PASSES="$UNEXPECTED_PASSES $invalid_json" + fi + done done RED='\033[0;31m' From f0482a66ede6ea85380008c01a07b5a5d14591ab Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 24 Dec 2025 18:07:34 +0000 Subject: [PATCH 038/149] add isHole, test there are no holes in resHugr --- brat/Data/Hugr.hs | 5 +++++ brat/Data/HugrGraph.hs | 4 ++-- brat/test/Test/HugrGraph.hs | 7 +++++-- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/brat/Data/Hugr.hs b/brat/Data/Hugr.hs index 9791134d..6ea8b202 100644 --- a/brat/Data/Hugr.hs +++ b/brat/Data/Hugr.hs @@ -455,6 +455,11 @@ holeOp :: Int -> FunctionType -> CustomOp holeOp idx sig = CustomOp "BRAT" "Hole" sig [TANat idx, TAType (HTFunc (PolyFuncType [] sig))] +isHole :: HugrOp -> Maybe (Int, FunctionType) +isHole (OpCustom (CustomOp "BRAT" "Hole" sig args)) = + let [TANat idx, _] = args in Just (idx, sig) -- crash rather than return false for bad args +isHole _ = Nothing + -- TYPE ARGS: -- * A length-2 sequence comprising: -- * A sequence of types (the inputs of outerSig) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 84f04ef3..22ce819b 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -101,8 +101,8 @@ getOp HugrGraph {nodes} n = nodes M.! n --- Replaces the specified node of the first Hugr, with the second Hugr. splice :: HugrGraph -> NodeId -> HugrGraph -> HugrGraph -splice host hole add = case M.lookup hole (nodes host) of - Just (OpCustom (CustomOp "BRAT" "Hole" sig _)) -> case M.lookup (root add) (nodes add) of +splice host hole add = case (M.lookup hole (nodes host) >>= isHole) of + Just (_, sig) -> case M.lookup (root add) (nodes add) of Just (OpDFG (DFG sig' _)) | sig == sig' -> {-inlineDFG hole-} host { -- prefer host entry for parent of (`hole` == root of `add`) parents = union (parents host) (M.mapKeys k $ M.map k $ parents add), diff --git a/brat/test/Test/HugrGraph.hs b/brat/test/Test/HugrGraph.hs index 7cd1688a..b15382fd 100644 --- a/brat/test/Test/HugrGraph.hs +++ b/brat/test/Test/HugrGraph.hs @@ -7,6 +7,8 @@ import Data.Hugr import Control.Monad.State (State, execState, get, runState) import Data.Aeson (encode) import Data.Functor ((<&>)) +import Data.Maybe (isJust, isNothing) +import Data.List (find) import qualified Data.ByteString.Lazy as BS import System.Directory (createDirectoryIfMissing) import System.FilePath @@ -30,9 +32,10 @@ testSplice = testCaseInfo "splice" $ do let (h, holeId) = host BS.writeFile (outputDir "host.json") (encode $ H.serialize h) BS.writeFile (outputDir "insertee.json") (encode $ H.serialize dfgHugr) - let resHugr = H.splice h holeId dfgHugr + let resHugr@(Hugr (ns, _)) = H.serialize $ H.splice h holeId dfgHugr let outFile = outputDir "result.json" - BS.writeFile outFile (encode $ H.serialize resHugr) + BS.writeFile outFile $ encode resHugr + assertBool "Should be no holes now" $ isNothing $ find (isJust . isHole) $ snd <$> ns pure $ "Written to " ++ outFile ++ " pending validation" where host :: (HugrGraph, NodeId) From 0369fbf3cc469e890884e17d718c895db45c017a Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 24 Dec 2025 17:26:24 +0000 Subject: [PATCH 039/149] Add inlineDFG --- brat/Data/HugrGraph.hs | 71 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 68 insertions(+), 3 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 22ce819b..a1a4e4e9 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -6,15 +6,17 @@ module Data.HugrGraph(NodeId, setFirstChildren, setOp, getParent, getOp, addEdge, addOrderEdge, edgeList, - splice, serialize + splice, inlineDFG, + serialize ) where import Brat.Naming (Namespace, Name(..), fresh, split) import Bwd import Data.Hugr hiding (const) -import Control.Monad.State (State, execState, state) +import Control.Monad.State (State, execState, state, get, put, modify) import Data.Foldable (for_) +import Data.Functor ((<&>)) import Data.Bifunctor (first) import Data.Maybe (fromMaybe) import qualified Data.Map as M @@ -129,6 +131,69 @@ splice host hole add = case (M.lookup hole (nodes host) >>= isHole) of union = M.unionWith (\_ _ -> error "keys not disjoint") k = (keyMap M.!) +inlineDFG :: NodeId -> State HugrGraph () +inlineDFG dfg = get >>= \h -> case M.lookup dfg (nodes h) of + (Just (OpDFG _)) -> do + let newp = (parents h) M.! dfg + let [inp, out] = (first_children h) M.! dfg + -- rewire edges + dfg_in_map <- takeInEdgeMap dfg + input_out_map <- takeOutEdges inp + for_ input_out_map $ \(outp, dest) -> addEdge (dfg_in_map M.! outp, dest) + dfg_out_map <- takeOutEdges dfg + output_in_map <- takeInEdgeMap out + for_ dfg_out_map $ \(outp, dest) -> addEdge (output_in_map M.! outp, dest) + -- remove dfg, inp, out; reparent children of dfg + let to_remove = [dfg, inp, out] + modify $ \h -> h { + first_children = M.delete dfg (first_children h), -- inp/out shouldn't have any children + nodes = foldl (flip M.delete) (nodes h) to_remove, + -- TODO this is O(size of hugr) reparenting. Either add a child map, + -- or combine with splicing so we only iterate through the inserted + -- hugr (which we do anyway) rather than the host. + parents = M.fromList [(n, if p==dfg then newp else p) + | (n,p) <- M.assocs (parents h), not (elem n to_remove)] + } + other -> error $ "Expected DFG, found " ++ show other + where + takeInEdgeMap n = takeInEdges n <&> \es -> M.fromList [(p, src) | (src, p) <- es] + +takeInEdges :: NodeId -> State HugrGraph [(PortId NodeId, Int)] +takeInEdges tgt = do + h <- get + let (removed_edges, edges_in') = first (fromMaybe []) $ M.updateLookupWithKey + (\_ _ -> Nothing) tgt (edges_in h) + let edges_out' = foldl removeFromOutMap (edges_out h) removed_edges + put h {edges_in=edges_in', edges_out=edges_out'} + pure removed_edges + where + removeFromOutMap :: M.Map NodeId [(Int, PortId NodeId)] -> (PortId NodeId, Int) -> M.Map NodeId [(Int, PortId NodeId)] + removeFromOutMap eos (Port src outport, inport) = M.alter (\(Just es) -> Just $ removeFromOutList es (outport, Port tgt inport)) src eos + + removeFromOutList :: [(Int, PortId NodeId)] -> (Int, PortId NodeId) -> [(Int, PortId NodeId)] + removeFromOutList [] _ = error "Out-edge not found" + removeFromOutList (e:es) e' | e == e' = es + removeFromOutList ((outport, _):_) (outport', _) | outport == outport' = error "Wrong out-edge" + removeFromOutList (e:es) r = e:(removeFromOutList es r) + +takeOutEdges :: NodeId -> State HugrGraph [(Int, PortId NodeId)] +takeOutEdges src = do + h <- get + let (removed_edges, edges_out') = first (fromMaybe []) $ M.updateLookupWithKey + (\_ _ -> Nothing) src (edges_out h) + let edges_in' = foldl removeFromInMap (edges_in h) removed_edges + put h {edges_in=edges_in', edges_out=edges_out'} + pure removed_edges + where + removeFromInMap :: M.Map NodeId [(PortId NodeId, Int)] -> (Int, PortId NodeId) -> M.Map NodeId [(PortId NodeId, Int)] + removeFromInMap eis (outport, Port tgt inport) = M.alter (\(Just es) -> Just $ removeFromInList es (Port src outport, inport)) tgt eis + + removeFromInList:: [(PortId NodeId, Int)] -> (PortId NodeId, Int) -> [(PortId NodeId, Int)] + removeFromInList [] _ = error "In-edge not found" + removeFromInList (e:es) e' | e==e' = es + removeFromInList ((_, inport):_) (_,inport') | inport == inport' = error "Wrong in-edge" + removeFromInList (e:es) r = e:(removeFromInList es r) + serialize :: HugrGraph -> Hugr Int serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) where @@ -171,7 +236,7 @@ renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr nodeStackAndIndices = let just_root = (B0 :< (root, nodes M.! root), M.singleton root 0) init = foldl addNode just_root (first_children root) in foldl addNode init (M.keys parents) - + addNode :: StackAndIndices -> NodeId -> StackAndIndices addNode ins n = case M.lookup n (snd ins) of (Just _) -> ins From 7c6c608c8369c38e1f277f8a1ae4fc535bb24b07 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 24 Dec 2025 18:33:02 +0000 Subject: [PATCH 040/149] Parametrize test both with and without inlining --- brat/test/Test/HugrGraph.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/brat/test/Test/HugrGraph.hs b/brat/test/Test/HugrGraph.hs index b15382fd..b9c10580 100644 --- a/brat/test/Test/HugrGraph.hs +++ b/brat/test/Test/HugrGraph.hs @@ -25,19 +25,26 @@ addNode nam parent op = do pure name getSpliceTests :: IO TestTree -getSpliceTests = createDirectoryIfMissing True outputDir >> pure testSplice +getSpliceTests = do + createDirectoryIfMissing True outputDir + pure $ testGroup "splice" [testSplice False, testSplice True] -testSplice :: TestTree -testSplice = testCaseInfo "splice" $ do +testSplice :: Bool -> TestTree +testSplice inline = testCaseInfo name $ do let (h, holeId) = host - BS.writeFile (outputDir "host.json") (encode $ H.serialize h) - BS.writeFile (outputDir "insertee.json") (encode $ H.serialize dfgHugr) - let resHugr@(Hugr (ns, _)) = H.serialize $ H.splice h holeId dfgHugr - let outFile = outputDir "result.json" + let outPrefix = outputDir name + BS.writeFile (outPrefix ++ "_host.json") (encode $ H.serialize h) + BS.writeFile (outPrefix ++ "_insertee.json") (encode $ H.serialize dfgHugr) + let spliced = H.splice h holeId dfgHugr + let resHugr@(Hugr (ns, _)) = H.serialize $ if inline + then execState (inlineDFG holeId) spliced else spliced + let outFile = outPrefix ++ "_result.json" BS.writeFile outFile $ encode resHugr assertBool "Should be no holes now" $ isNothing $ find (isJust . isHole) $ snd <$> ns + -- if inline, we should assert there's no DFG either pure $ "Written to " ++ outFile ++ " pending validation" where + name = if inline then "inline" else "noinline" host :: (HugrGraph, NodeId) host = swap $ flip runState (H.new N.root "root" rootDefn) $ do root <- get <&> H.root From 6b6ba8cdc44c659246df7e7e56bf46e3a465d211 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 9 Dec 2025 10:01:26 +0000 Subject: [PATCH 041/149] WIP add Machine.hs --- brat/Brat/Graph.hs | 10 ++++-- brat/Brat/Machine.hs | 86 ++++++++++++++++++++++++++++++++++++++++++++ brat/brat.cabal | 1 + 3 files changed, 94 insertions(+), 3 deletions(-) create mode 100644 brat/Brat/Machine.hs diff --git a/brat/Brat/Graph.hs b/brat/Brat/Graph.hs index 62c4619b..4096cf5d 100644 --- a/brat/Brat/Graph.hs +++ b/brat/Brat/Graph.hs @@ -110,9 +110,6 @@ toGraph (ns, ws) = G.graphFromEdges adj ) | (name, node) <- M.toList ns] -wiresFrom :: Name -> Graph -> [Wire] -wiresFrom src (_, ws) = [ w | w@(Ex a _, _, _) <- ws, a == src ] - lookupNode :: Name -> Graph -> Maybe Node lookupNode name (ns, _) = M.lookup name ns @@ -121,3 +118,10 @@ wireStart (Ex x _, _, _) = x wireEnd :: Wire -> Name wireEnd (_, _, In x _) = x + +-- These are horribly inefficient until we use a better structure for graph edges +wiresFrom :: Name -> Graph -> [Wire] +wiresFrom src (_, ws) = [ w | w@(Ex a _, _, _) <- ws, a == src ] + +wiresTo :: Name -> Graph -> [Wire] +wiresTo tgt (_, ws) = [ w | w@(_, _, In a _) <- ws, a == tgt ] diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs new file mode 100644 index 00000000..2ed07668 --- /dev/null +++ b/brat/Brat/Machine.hs @@ -0,0 +1,86 @@ +module Brat.Machine where + +import Brat.Naming (Name, Namespace) +import Brat.Graph (Graph, NodeType (..), Node (BratNode, KernelNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..)) +import Brat.Syntax.Port (OutPort(..)) +import Brat.Syntax.Common +import Brat.Syntax.Value + +import Hasochism + +import qualified Data.Map as M +import Bwd + +data Frame where + BratValues :: EvalEnv -> Frame + -- Node weight, name+offset requested, state of evaluating inputs: + -- (values computed, ports whose values still needed) + EvalNodeInputs :: Node -> OutPort -> Bwd Value -> [OutPort] -> Frame + HandleNodeOutputs :: OutPort -> Frame + deriving Show + +data Task where + EvalPort :: OutPort -> Task + Suspend :: [Frame] -> Task -> Task + EvalNode :: Node -> [Value] -> Task + Use :: Value -> Task -- searches for EvalNodeInputs + NodeFinished :: [Value] -> Task -- searches for HandleNodeOutputs + deriving Show + +lookupOutport :: Bwd Frame -> OutPort -> Maybe Value +lookupOutport B0 _ = Nothing +lookupOutport (fz :< BratValues env) p | Just v <- M.lookup env p = Just v +lookupOutport (fz :< _) p = lookupOutport fz p + +nextInput :: Graph -> Bwd Frame -> Node -> OutPort -> Bwd Value -> [OutPort] -> Task +-- EvalNodeInputs is "missing" one input (between valz and ports), i.e. the one that's the current Task +-- (whereas nextInput has them all) +nextInput g fz nw requested valz (p:ps) = run g (fz :< EvalNodeInputs nw requested valz ps) (EvalPort p) +nextInput g fz nw requested valz [] = run g (fz :< HandleNodeOutputs requested) (EvalNode nw (valz <>> [])) + +updateCache (fz :< BratValues env) port_vals = fz :< (BratValues $ foldr (uncurry M.insert) env port_vals) +updateCache (fz :< f) pvs = (updateCache fz pvs) :< f +-- updateCache B0 pvs = B0 :< (M.fromList pvs) + +run :: Graph -> Bwd Frame -> Task -> Task +run g@(nodes, wires) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of + Just v -> run g fz (Use v) + Nothing -> + -- might be good to check M.keys == [0,1,....] here + let srcs = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) + in nextInput g fz (nodes M.! name) p B0 srcs +run g (fz :< EvalNodeInputs nw req valz rem) (Use v) = nextInput g fz nw req (valz :< v) rem +-- run g (fz :< f) (Use v) = let t = run g fz (Use v) in -- not yet +run g (fz :< HandleNodeOutputs req@(Ex name offset)) (NodeFinished vals) = + run g (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] vals]) (Use (vals !! offset)) +run g fz (EvalNode nw inputVals) = todo -- case nw of + +run g (fz :< f) (Suspend fs t) = run g fz (Suspend (f:fs) t) +run _ B0 t@(Suspend _ _) = t +run g fz t = run g fz (Suspend [] t) + +data Value = + IntV Int + | FloatV Double + | BoolV Bool + | VecV [Value] + | ThunkV BratThunk + | KernelV HugrKernel + +data BratThunk = + -- this might want to be [EvalEnv] or something like that + BratClosure EvalEnv Name Name -- Captured environment, src node, tgt node + | BratPrim String String (CTy Brat Z) + +data HugrKernel deriving Show + +instance Show Value where + show (IntV x) = show x + show (FloatV x) = show x + show (BoolV x) = show x + show (VecV xs) = show xs + show (ThunkV _) = "" + show (KernelV k) = "Kernel (" ++ show k ++ ")" + +type EvalEnv = M.Map OutPort Value + diff --git a/brat/brat.cabal b/brat/brat.cabal index 51ad35c3..fc256cff 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -78,6 +78,7 @@ library Brat.Error, Brat.Graph, Brat.Load, + Brat.Machine, Brat.Parser, Brat.Search, Brat.Elaborator, From 72d8527d6f416ba9c61a97a404e4f7ee38f58a27 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 9 Dec 2025 12:33:47 +0000 Subject: [PATCH 042/149] Evaluates constant 4 --- brat/Brat/Compiler.hs | 13 ++++++--- brat/Brat/Load.hs | 1 + brat/Brat/Machine.hs | 68 +++++++++++++++++++++++++++++++------------ brat/app/Main.hs | 12 ++++++-- brat/brat.cabal | 4 --- 5 files changed, 69 insertions(+), 29 deletions(-) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index 093195be..0eb95dfc 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -3,6 +3,7 @@ module Brat.Compiler (printAST ,writeDot ,compileFile ,compileAndPrintFile + ,compileToGraph ,CompilingHoles(..) ) where @@ -12,7 +13,7 @@ import Brat.Dot (toDotString) import Brat.Elaborator import Brat.Error import Brat.Load -import Brat.Naming (root, split) +import Brat.Naming (Namespace, root, split) import Control.Exception (evaluate) import Control.Monad (when) @@ -71,11 +72,15 @@ instance Show CompilingHoles where show (CompilingHoles hs) = unlines $ "Can't compile file with remaining holes": fmap ((" " ++) . show) hs -compileFile :: [FilePath] -> String -> IO (Either CompilingHoles BS.ByteString) -compileFile libDirs file = do +compileToGraph :: [FilePath] -> String -> IO (Namespace, VMod) +compileToGraph libDirs file = do let (checkRoot, newRoot) = split "checking" root env <- runExceptT $ loadFilename checkRoot libDirs file - (venv, _, holes, defs, outerGraph, capSets) <- eitherIO env + (newRoot,) <$> eitherIO env + +compileFile :: [FilePath] -> String -> IO (Either CompilingHoles BS.ByteString) +compileFile libDirs file = do + (newRoot, (venv, _, holes, defs, outerGraph, capSets)) <- compileToGraph libDirs file case holes of [] -> Right <$> evaluate -- turns 'error' into IO 'die' (compile defs newRoot outerGraph capSets venv) diff --git a/brat/Brat/Load.hs b/brat/Brat/Load.hs index 75570454..0df3f0ad 100644 --- a/brat/Brat/Load.hs +++ b/brat/Brat/Load.hs @@ -2,6 +2,7 @@ module Brat.Load (loadFilename ,loadFiles ,parseFile ,desugarEnv + ,VMod ) where import Brat.Checker diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 2ed07668..b8c5777e 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -1,7 +1,10 @@ -module Brat.Machine where +module Brat.Machine (runInterpreter) where +import Brat.Compiler (compileToGraph) import Brat.Naming (Name, Namespace) import Brat.Graph (Graph, NodeType (..), Node (BratNode, KernelNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..)) +import Brat.QualName (plain) +import Brat.Syntax.Simple (SimpleTerm(..)) import Brat.Syntax.Port (OutPort(..)) import Brat.Syntax.Common import Brat.Syntax.Value @@ -11,11 +14,22 @@ import Hasochism import qualified Data.Map as M import Bwd +runInterpreter :: [FilePath] -> String -> String -> IO () +runInterpreter libDirs file runFunc = do + (_, (venv, _, _, _, outerGraph, _)) <- compileToGraph libDirs file + print (show outerGraph) + let outPorts = [op | (NamedPort op _, _ty) <- venv M.! (plain runFunc)] + let outTask = evalPorts outerGraph (B0 :< BratValues M.empty) B0 outPorts + -- we hope outTask is a Finished. Or a Suspend. + print outTask + pure () + data Frame where BratValues :: EvalEnv -> Frame - -- Node weight, name+offset requested, state of evaluating inputs: - -- (values computed, ports whose values still needed) - EvalNodeInputs :: Node -> OutPort -> Bwd Value -> [OutPort] -> Frame + -- Optionally "what to do when all ports evaled" - Node weight, name+offset requested + -- then state of evaluating inputs: (values computed, ports whose values still needed) + EvalPorts :: Bwd Value -> [OutPort] -> Frame + PortOfNode :: OutPort -> Frame HandleNodeOutputs :: OutPort -> Frame deriving Show @@ -23,42 +37,60 @@ data Task where EvalPort :: OutPort -> Task Suspend :: [Frame] -> Task -> Task EvalNode :: Node -> [Value] -> Task - Use :: Value -> Task -- searches for EvalNodeInputs - NodeFinished :: [Value] -> Task -- searches for HandleNodeOutputs + Use :: Value -> Task -- searches for EvalPorts + Finished :: [Value] -> Task -- searches for HandleNodeOutputs, or final result deriving Show lookupOutport :: Bwd Frame -> OutPort -> Maybe Value lookupOutport B0 _ = Nothing -lookupOutport (fz :< BratValues env) p | Just v <- M.lookup env p = Just v +lookupOutport (_ :< BratValues env) p | Just v <- M.lookup p env = Just v lookupOutport (fz :< _) p = lookupOutport fz p -nextInput :: Graph -> Bwd Frame -> Node -> OutPort -> Bwd Value -> [OutPort] -> Task --- EvalNodeInputs is "missing" one input (between valz and ports), i.e. the one that's the current Task --- (whereas nextInput has them all) -nextInput g fz nw requested valz (p:ps) = run g (fz :< EvalNodeInputs nw requested valz ps) (EvalPort p) -nextInput g fz nw requested valz [] = run g (fz :< HandleNodeOutputs requested) (EvalNode nw (valz <>> [])) +evalPorts :: Graph -> Bwd Frame -> Bwd Value -> [OutPort] -> Task +-- EvalPorts is "missing" one input (between valz and ports), i.e. the one that's the current Task +-- (whereas evalPorts has them all) +evalPorts g fz valz (p:ps) = run g (fz :< EvalPorts valz ps) (EvalPort p) +evalPorts g fz valz [] = run g fz (Finished (valz <>> [])) updateCache (fz :< BratValues env) port_vals = fz :< (BratValues $ foldr (uncurry M.insert) env port_vals) updateCache (fz :< f) pvs = (updateCache fz pvs) :< f -- updateCache B0 pvs = B0 :< (M.fromList pvs) run :: Graph -> Bwd Frame -> Task -> Task +-- Tasks that push new frames onto the stack to do things run g@(nodes, wires) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of Just v -> run g fz (Use v) Nothing -> -- might be good to check M.keys == [0,1,....] here let srcs = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) - in nextInput g fz (nodes M.! name) p B0 srcs -run g (fz :< EvalNodeInputs nw req valz rem) (Use v) = nextInput g fz nw req (valz :< v) rem --- run g (fz :< f) (Use v) = let t = run g fz (Use v) in -- not yet -run g (fz :< HandleNodeOutputs req@(Ex name offset)) (NodeFinished vals) = - run g (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] vals]) (Use (vals !! offset)) -run g fz (EvalNode nw inputVals) = todo -- case nw of + in evalPorts g (fz :< PortOfNode p) B0 srcs +run g fz (EvalNode (BratNode (Const st) _ _) []) = run g fz (Finished [evalSimpleTerm st]) +run g fz (EvalNode (BratNode Id _ _) ins) = run g fz (Finished ins) +-- Tasks that unwind the stack looking for what to do with the result run g (fz :< f) (Suspend fs t) = run g fz (Suspend (f:fs) t) run _ B0 t@(Suspend _ _) = t +run g (fz :< EvalPorts valz rem) (Use v) = evalPorts g fz (valz :< v) rem +run g@(nodes, _) (fz :< PortOfNode req@(Ex name offset)) (Finished inputs) = + run g (fz :< HandleNodeOutputs req) (EvalNode (nodes M.! name) inputs) + +run g (fz :< HandleNodeOutputs req@(Ex name offset)) (Finished outputs) = + run g (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] outputs]) (Use (outputs !! offset)) + +run g (fz :< BratValues _) t = run g fz t run g fz t = run g fz (Suspend [] t) + +buildEnv :: Bwd Frame -> EvalEnv +buildEnv B0 = M.empty +buildEnv (fz :< BratValues env) = M.union (buildEnv fz) env +buildEnv (fz :< _) = buildEnv fz + +evalSimpleTerm :: SimpleTerm -> Value +evalSimpleTerm (Num x) = IntV x +evalSimpleTerm (Float x) = FloatV x +evalSimpleTerm t = error ("todo " ++ show t) + data Value = IntV Int | FloatV Double diff --git a/brat/app/Main.hs b/brat/app/Main.hs index bac393b7..95a35ee3 100644 --- a/brat/app/Main.hs +++ b/brat/app/Main.hs @@ -1,4 +1,5 @@ import Brat.Compiler +import Brat.Machine (runInterpreter) import Control.Monad (when) import Options.Applicative @@ -9,7 +10,8 @@ data Options = Opt { compile :: Bool, file :: String, libs :: String, - raw :: Bool + raw :: Bool, + runFunc :: String } compileFlag :: Parser Bool @@ -23,8 +25,10 @@ dotOption = strOption (long "dot" <> value "" <> help "Write graph in Dot format libOption = strOption (long "lib" <> value "" <> help "Look in extra directories for libraries (delimited with ;)") +runFuncOption = strOption (long "run" <> value "" <> help "Run function with interpreter (must take no arguments)") + opts :: Parser Options -opts = Opt <$> astFlag <*> dotOption <*> compileFlag <*> strArgument (metavar "FILE") <*> libOption <*> rawFlag +opts = Opt <$> astFlag <*> dotOption <*> compileFlag <*> strArgument (metavar "FILE") <*> libOption <*> rawFlag <*> runFuncOption -- Parse a list of library directories delimited by a semicolon parseLibs :: String -> [String] @@ -39,4 +43,6 @@ main = do when (ast || raw) $ printAST raw ast file let libDirs = parseLibs libs when (dot /= "") $ writeDot libDirs file dot - if compile then compileAndPrintFile libDirs file else printDeclsHoles libDirs file + if compile then compileAndPrintFile libDirs file + else if runFunc /= "" then runInterpreter libDirs file runFunc + else printDeclsHoles libDirs file diff --git a/brat/brat.cabal b/brat/brat.cabal index fc256cff..bbb65255 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -44,11 +44,7 @@ common warning-flags -Wno-unused-do-bind -Wno-missing-signatures -Wno-noncanonical-monoid-instances - -Werror=unused-imports - -Werror=unused-matches -Werror=missing-methods - -Werror=unused-top-binds - -Werror=unused-local-binds -Werror=redundant-constraints -Werror=orphans -Werror=overlapping-patterns From 18a60e0b65c5ecc4f0fece5fd293f1bcd8e51b14 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 9 Dec 2025 12:47:52 +0000 Subject: [PATCH 043/149] And simple arithmetic --- brat/Brat/Machine.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index b8c5777e..984f3c64 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -65,6 +65,7 @@ run g@(nodes, wires) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p let srcs = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) in evalPorts g (fz :< PortOfNode p) B0 srcs run g fz (EvalNode (BratNode (Const st) _ _) []) = run g fz (Finished [evalSimpleTerm st]) +run g fz (EvalNode (BratNode (ArithNode op) _ _) ins) = run g fz (Finished [evalArith op ins]) run g fz (EvalNode (BratNode Id _ _) ins) = run g fz (Finished ins) -- Tasks that unwind the stack looking for what to do with the result @@ -91,6 +92,21 @@ evalSimpleTerm (Num x) = IntV x evalSimpleTerm (Float x) = FloatV x evalSimpleTerm t = error ("todo " ++ show t) +evalArith :: ArithOp -> [Value] -> Value +evalArith op [IntV x, IntV y] = IntV $ case op of + Add -> x + y + Sub -> x - y + Mul -> x * y + Div -> div x y + Pow -> x ^ y +evalArith op [FloatV x, FloatV y] = FloatV $ case op of + Add -> x + y + Sub -> x - y + Mul -> x * y + Div -> x / y + Pow -> x ** y +evalArith _ _ = error "Bad arith inputs" + data Value = IntV Int | FloatV Double From c5a23d040ba411bfc8a51116b9b6efaa7d3a4a2b Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 9 Dec 2025 16:30:44 +0000 Subject: [PATCH 044/149] WIP Eval, Box with captureSets and ReturnTo --- brat/Brat/Machine.hs | 75 +++++++++++++++++++++++++++++--------------- 1 file changed, 50 insertions(+), 25 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 984f3c64..34a01ad4 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -1,9 +1,10 @@ module Brat.Machine (runInterpreter) where +import Brat.Checker.Monad (CaptureSets) import Brat.Compiler (compileToGraph) import Brat.Naming (Name, Namespace) import Brat.Graph (Graph, NodeType (..), Node (BratNode, KernelNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..)) -import Brat.QualName (plain) +import Brat.QualName (QualName, plain) import Brat.Syntax.Simple (SimpleTerm(..)) import Brat.Syntax.Port (OutPort(..)) import Brat.Syntax.Common @@ -11,15 +12,19 @@ import Brat.Syntax.Value import Hasochism +import Data.Maybe (fromMaybe) import qualified Data.Map as M +import qualified Data.Set as S import Bwd +type GraphInfo = (Graph, CaptureSets) + runInterpreter :: [FilePath] -> String -> String -> IO () runInterpreter libDirs file runFunc = do - (_, (venv, _, _, _, outerGraph, _)) <- compileToGraph libDirs file + (_, (venv, _, _, _, outerGraph, capSets)) <- compileToGraph libDirs file print (show outerGraph) let outPorts = [op | (NamedPort op _, _ty) <- venv M.! (plain runFunc)] - let outTask = evalPorts outerGraph (B0 :< BratValues M.empty) B0 outPorts + let outTask = evalPorts (outerGraph,capSets) (B0 :< BratValues M.empty) B0 outPorts -- we hope outTask is a Finished. Or a Suspend. print outTask pure () @@ -31,12 +36,15 @@ data Frame where EvalPorts :: Bwd Value -> [OutPort] -> Frame PortOfNode :: OutPort -> Frame HandleNodeOutputs :: OutPort -> Frame + -- have arguments to function, waiting for the function: + CallWith :: [Value] -> Frame + ReturnTo :: Bwd Frame -> Frame deriving Show data Task where EvalPort :: OutPort -> Task Suspend :: [Frame] -> Task -> Task - EvalNode :: Node -> [Value] -> Task + EvalNode :: Name -> [Value] -> Task Use :: Value -> Task -- searches for EvalPorts Finished :: [Value] -> Task -- searches for HandleNodeOutputs, or final result deriving Show @@ -46,46 +54,63 @@ lookupOutport B0 _ = Nothing lookupOutport (_ :< BratValues env) p | Just v <- M.lookup p env = Just v lookupOutport (fz :< _) p = lookupOutport fz p -evalPorts :: Graph -> Bwd Frame -> Bwd Value -> [OutPort] -> Task +evalPorts :: GraphInfo -> Bwd Frame -> Bwd Value -> [OutPort] -> Task -- EvalPorts is "missing" one input (between valz and ports), i.e. the one that's the current Task -- (whereas evalPorts has them all) evalPorts g fz valz (p:ps) = run g (fz :< EvalPorts valz ps) (EvalPort p) evalPorts g fz valz [] = run g fz (Finished (valz <>> [])) +evalNodeInputs :: GraphInfo -> Bwd Frame -> Name -> Task +evalNodeInputs gi@(g,_) fz name = + -- might be good to check M.keys == [0,1,....] here + let srcs = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) + in evalPorts gi fz B0 srcs + updateCache (fz :< BratValues env) port_vals = fz :< (BratValues $ foldr (uncurry M.insert) env port_vals) updateCache (fz :< f) pvs = (updateCache fz pvs) :< f -- updateCache B0 pvs = B0 :< (M.fromList pvs) -run :: Graph -> Bwd Frame -> Task -> Task +run :: GraphInfo -> Bwd Frame -> Task -> Task -- Tasks that push new frames onto the stack to do things -run g@(nodes, wires) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of - Just v -> run g fz (Use v) - Nothing -> - -- might be good to check M.keys == [0,1,....] here - let srcs = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) - in evalPorts g (fz :< PortOfNode p) B0 srcs -run g fz (EvalNode (BratNode (Const st) _ _) []) = run g fz (Finished [evalSimpleTerm st]) -run g fz (EvalNode (BratNode (ArithNode op) _ _) ins) = run g fz (Finished [evalArith op ins]) -run g fz (EvalNode (BratNode Id _ _) ins) = run g fz (Finished ins) - +run gi@(g@(nodes, wires), _) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of + Just v -> run gi fz (Use v) + Nothing -> evalNodeInputs gi (fz :< PortOfNode p) name +run g@((nodes, _), cs) fz t@(EvalNode n ins) = case nodes M.! n of + (BratNode (Const st) _ _) -> run g fz (Finished [evalSimpleTerm st]) + (BratNode (ArithNode op) _ _) -> run g fz (Finished [evalArith op ins]) + (BratNode Id _ _) -> run g fz (Finished ins) + (BratNode (Eval func) _ _) -> run g (fz :< CallWith ins) (EvalPort func) + (BratNode (Box src tgt) _ _) -> + let captureSet = fromMaybe M.empty (M.lookup n cs) + capturedSrcs = S.fromList [src | (NamedPort src _name, _ty) <- concat (M.elems captureSet)] + in run g fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) + _ -> run g fz (Suspend [] t) -- Tasks that unwind the stack looking for what to do with the result -run g (fz :< f) (Suspend fs t) = run g fz (Suspend (f:fs) t) +----Suspend +run gi (fz :< f) (Suspend fs t) = run gi fz (Suspend (f:fs) t) run _ B0 t@(Suspend _ _) = t -run g (fz :< EvalPorts valz rem) (Use v) = evalPorts g fz (valz :< v) rem -run g@(nodes, _) (fz :< PortOfNode req@(Ex name offset)) (Finished inputs) = - run g (fz :< HandleNodeOutputs req) (EvalNode (nodes M.! name) inputs) - +---- Use (single value) +run gi (fz :< EvalPorts valz rem) (Use v) = evalPorts gi fz (valz :< v) rem +run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = + let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] + in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt + +---- Finished (list of values) +run g (fz :< PortOfNode req@(Ex name offset)) (Finished inputs) = + run g (fz :< HandleNodeOutputs req) (EvalNode name inputs) run g (fz :< HandleNodeOutputs req@(Ex name offset)) (Finished outputs) = run g (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] outputs]) (Use (outputs !! offset)) +run g (B0 :< ReturnTo fz) (Finished vals) = run g fz (Finished vals) run g (fz :< BratValues _) t = run g fz t +run g B0 t = t run g fz t = run g fz (Suspend [] t) -buildEnv :: Bwd Frame -> EvalEnv -buildEnv B0 = M.empty -buildEnv (fz :< BratValues env) = M.union (buildEnv fz) env -buildEnv (fz :< _) = buildEnv fz +captureEnv :: Bwd Frame -> S.Set OutPort -> EvalEnv +captureEnv B0 _ = M.empty +captureEnv (fz :< BratValues env) keys = M.union (captureEnv fz keys) (M.filterWithKey (\k _ -> S.member k keys) env) +captureEnv (fz :< _) keys = captureEnv fz keys evalSimpleTerm :: SimpleTerm -> Value evalSimpleTerm (Num x) = IntV x From b953fe15295f51d27b6b678e8922a4e4cd9874e1 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 9 Dec 2025 16:53:03 +0000 Subject: [PATCH 045/149] start pattern matching - works if no tests --- brat/Brat/Machine.hs | 31 +++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 34a01ad4..21a5d9e9 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -2,6 +2,7 @@ module Brat.Machine (runInterpreter) where import Brat.Checker.Monad (CaptureSets) import Brat.Compiler (compileToGraph) +import Brat.Constructors.Patterns import Brat.Naming (Name, Namespace) import Brat.Graph (Graph, NodeType (..), Node (BratNode, KernelNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..)) import Brat.QualName (QualName, plain) @@ -12,10 +13,14 @@ import Brat.Syntax.Value import Hasochism -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, fromJust) +import Data.List.NonEmpty hiding ((!!), zip) import qualified Data.Map as M import qualified Data.Set as S import Bwd +import Util (zipSameLength) + +import Debug.Trace type GraphInfo = (Graph, CaptureSets) @@ -39,6 +44,8 @@ data Frame where -- have arguments to function, waiting for the function: CallWith :: [Value] -> Frame ReturnTo :: Bwd Frame -> Frame + Alternatives :: [(TestMatchData Brat, Name)] -> [Value] -> Frame + PerformMatchTests :: [(Src, PrimTest (BinderType Brat))] -> [(Src, BinderType Brat)] -> Name -> Frame deriving Show data Task where @@ -47,6 +54,9 @@ data Task where EvalNode :: Name -> [Value] -> Task Use :: Value -> Task -- searches for EvalPorts Finished :: [Value] -> Task -- searches for HandleNodeOutputs, or final result + TryNextMatch :: Task + NoMatch :: Task + StuckOnNode :: Name -> Node -> Task deriving Show lookupOutport :: Bwd Frame -> OutPort -> Maybe Value @@ -84,7 +94,10 @@ run g@((nodes, _), cs) fz t@(EvalNode n ins) = case nodes M.! n of let captureSet = fromMaybe M.empty (M.lookup n cs) capturedSrcs = S.fromList [src | (NamedPort src _name, _ty) <- concat (M.elems captureSet)] in run g fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) - _ -> run g fz (Suspend [] t) + (BratNode (PatternMatch (c:|cs)) _ _) -> run g (fz :< Alternatives (c:cs) ins) TryNextMatch + nw -> run g fz (StuckOnNode n nw) + + -- Tasks that unwind the stack looking for what to do with the result ----Suspend run gi (fz :< f) (Suspend fs t) = run gi fz (Suspend (f:fs) t) @@ -102,10 +115,24 @@ run g (fz :< HandleNodeOutputs req@(Ex name offset)) (Finished outputs) = run g (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] outputs]) (Use (outputs !! offset)) run g (B0 :< ReturnTo fz) (Finished vals) = run g fz (Finished vals) +-- TryNextMatch +run g (fz :< Alternatives [] _) TryNextMatch = run g fz NoMatch +run g (fz :< Alternatives ((TestMatchData _ ms, box):cs) ins) TryNextMatch = + let MatchSequence matchInputs matchTests matchOutputs = ms + testInputs = M.fromList (fromJust $ zipSameLength [src | (NamedPort src _,_ty) <- matchInputs] ins) + outEnv = doAllTests testInputs matchTests + in case outEnv of + Nothing -> run g (fz :< Alternatives cs ins) TryNextMatch + Just env -> + let vals = [env M.! src | (NamedPort src _, _) <- matchOutputs] + in run g (fz :< CallWith vals) (EvalPort $ Ex box 0) + run g (fz :< BratValues _) t = run g fz t run g B0 t = t run g fz t = run g fz (Suspend [] t) +doAllTests :: EvalEnv -> [(Src, PrimTest (BinderType Brat))] -> Maybe EvalEnv +doAllTests env [] = Just env captureEnv :: Bwd Frame -> S.Set OutPort -> EvalEnv captureEnv B0 _ = M.empty From 33a8345386923b94f5d12391fe71c224222c56e1 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 9 Dec 2025 17:51:00 +0000 Subject: [PATCH 046/149] The test file I've been using --- brat/arith.brat | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 brat/arith.brat diff --git a/brat/arith.brat b/brat/arith.brat new file mode 100644 index 00000000..65d5e82b --- /dev/null +++ b/brat/arith.brat @@ -0,0 +1,24 @@ +i :: Nat +i = 3 + 4 + +j :: Nat +j = 7 - 2 + +f :: Float +f = 2.1 * 5.3 + +g :: Float +g = 7.2 - 3.9 + +inc(Nat) -> Nat +inc(x) = x + 1 + +foo :: Nat +foo = inc(inc(4) + inc(7)) + +dec(Nat) -> Nat +dec(0) = 0 +dec(succ(n)) = n + +goo :: Nat +goo = dec(foo) From 085ef76844634e9a911526a2d9770bb2201e0986 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 9 Dec 2025 17:48:16 +0000 Subject: [PATCH 047/149] Do tests for pattern matching --- brat/Brat/Machine.hs | 37 +++++++++++++++++++++++++++++-------- 1 file changed, 29 insertions(+), 8 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 21a5d9e9..4224b47e 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -14,7 +14,7 @@ import Brat.Syntax.Value import Hasochism import Data.Maybe (fromMaybe, fromJust) -import Data.List.NonEmpty hiding ((!!), zip) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as M import qualified Data.Set as S import Bwd @@ -133,6 +133,14 @@ run g fz t = run g fz (Suspend [] t) doAllTests :: EvalEnv -> [(Src, PrimTest (BinderType Brat))] -> Maybe EvalEnv doAllTests env [] = Just env +doAllTests env ((NamedPort outport _, test):tests) = + case test of + PrimLitTest term -> if testLiteral term (env M.! outport) + then doAllTests env tests + else Nothing + PrimCtorTest ctor ty _ outSrcs -> do + outputs <- testCtor ty ctor (env M.! outport) + doAllTests (env `M.union` M.fromList (zip (end . fst <$> outSrcs) outputs)) tests captureEnv :: Bwd Frame -> S.Set OutPort -> EvalEnv captureEnv B0 _ = M.empty @@ -142,7 +150,7 @@ captureEnv (fz :< _) keys = captureEnv fz keys evalSimpleTerm :: SimpleTerm -> Value evalSimpleTerm (Num x) = IntV x evalSimpleTerm (Float x) = FloatV x -evalSimpleTerm t = error ("todo " ++ show t) +evalSimpleTerm t = error ("todo " ++ show t) evalArith :: ArithOp -> [Value] -> Value evalArith op [IntV x, IntV y] = IntV $ case op of @@ -159,11 +167,25 @@ evalArith op [FloatV x, FloatV y] = FloatV $ case op of Pow -> x ** y evalArith _ _ = error "Bad arith inputs" -data Value = - IntV Int - | FloatV Double - | BoolV Bool - | VecV [Value] +testLiteral :: SimpleTerm -> Value -> Bool +testLiteral (Num x) (IntV y) = x == y +testLiteral (Float x) (FloatV y) = x == y +testLiteral _ _ = error "Internal error: Unexpected literal test" + +testCtor :: QualName -> QualName -> Value -> Maybe [Value] +testCtor CBool CTrue (BoolV True) = Just [] +testCtor CBool CFalse (BoolV False) = Just [] +testCtor CNat CZero (IntV 0) = Just [] +testCtor CNat CSucc (IntV x) | x > 0 = Just [IntV (x - 1)] +testCtor CVec CNil (VecV []) = Just [] +testCtor CVec CCons (VecV (v:vs)) = Just [v, VecV vs] +testCtor _ _ _ = Nothing + +data Value = + IntV Int + | FloatV Double + | BoolV Bool + | VecV [Value] | ThunkV BratThunk | KernelV HugrKernel @@ -183,4 +205,3 @@ instance Show Value where show (KernelV k) = "Kernel (" ++ show k ++ ")" type EvalEnv = M.Map OutPort Value - From 1e112fc3051107b78555d6a34231418b6f8aa44a Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 10 Dec 2025 11:29:21 +0000 Subject: [PATCH 048/149] Tests for vector even/odd tests (example falls over) --- brat/Brat/Machine.hs | 19 +++++++++++++++++++ brat/arith.brat | 10 ++++++++++ 2 files changed, 29 insertions(+) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 4224b47e..19ad179f 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -179,6 +179,25 @@ testCtor CNat CZero (IntV 0) = Just [] testCtor CNat CSucc (IntV x) | x > 0 = Just [IntV (x - 1)] testCtor CVec CNil (VecV []) = Just [] testCtor CVec CCons (VecV (v:vs)) = Just [v, VecV vs] +testCtor CVec CConcatEqEven (VecV vs) = do + (half, 0) <- pure (length vs `divMod` 2) + (xs, ys) <- pure (splitAt half vs) + pure [VecV xs, VecV ys] +testCtor CVec CRiffle (VecV vs) = do + (evens, odds) <- evenOdds vs + pure [VecV evens, VecV odds] + where + evenOdds :: [a] -> Maybe ([a], [a]) + evenOdds [] = pure ([], []) + evenOdds [x] = Nothing + evenOdds (x:y:xs) = do + (evens, odds) <- evenOdds xs + pure (x:evens, y:odds) + +testCtor CVec CConcatEqOdd (VecV vs) = do + (half, 1) <- pure (length vs `divMod` 2) + (xs, y:zs) <- pure (splitAt half vs) + pure [VecV xs, y, VecV zs] testCtor _ _ _ = Nothing data Value = diff --git a/brat/arith.brat b/brat/arith.brat index 65d5e82b..f2da9868 100644 --- a/brat/arith.brat +++ b/brat/arith.brat @@ -22,3 +22,13 @@ dec(succ(n)) = n goo :: Nat goo = dec(foo) + +length(X :: *, n :: #, Vec(X, n)) -> Nat +length(_, n, _) = n + +hoo(n :: #, Vec(Nat, n + 1)) -> Nat +hoo(succ(l), ls =, m ,= rs) = length(!, !, ls) +hoo(n, _) = n + +ioo :: Nat +ioo = hoo(!, [1,2,3]) From b81c28ef772e437979590531aadd332798fd3367 Mon Sep 17 00:00:00 2001 From: Conor McBride Date: Wed, 10 Dec 2025 12:02:26 +0000 Subject: [PATCH 049/149] tracing the machine --- brat/Brat/Machine.hs | 3 +++ brat/arith.brat | 3 +++ 2 files changed, 6 insertions(+) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 19ad179f..6ffcf634 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -81,11 +81,14 @@ updateCache (fz :< f) pvs = (updateCache fz pvs) :< f -- updateCache B0 pvs = B0 :< (M.fromList pvs) run :: GraphInfo -> Bwd Frame -> Task -> Task +run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined + -- Tasks that push new frames onto the stack to do things run gi@(g@(nodes, wires), _) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of Just v -> run gi fz (Use v) Nothing -> evalNodeInputs gi (fz :< PortOfNode p) name run g@((nodes, _), cs) fz t@(EvalNode n ins) = case nodes M.! n of + nw | trace ("EVALNODE " ++ show nw) False -> undefined (BratNode (Const st) _ _) -> run g fz (Finished [evalSimpleTerm st]) (BratNode (ArithNode op) _ _) -> run g fz (Finished [evalArith op ins]) (BratNode Id _ _) -> run g fz (Finished ins) diff --git a/brat/arith.brat b/brat/arith.brat index f2da9868..d6fdf5db 100644 --- a/brat/arith.brat +++ b/brat/arith.brat @@ -32,3 +32,6 @@ hoo(n, _) = n ioo :: Nat ioo = hoo(!, [1,2,3]) + +joo :: Vec(Nat, 3) +joo = [1,2,3] \ No newline at end of file From d3ba753471a11a0bf98aad1744a4e1cba6f69ff7 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 10 Dec 2025 12:24:59 +0000 Subject: [PATCH 050/149] Eval constructors --- brat/Brat/Machine.hs | 18 ++++++++++++++++++ brat/arith.brat | 4 ++-- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 6ffcf634..de6ef02d 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -98,6 +98,7 @@ run g@((nodes, _), cs) fz t@(EvalNode n ins) = case nodes M.! n of capturedSrcs = S.fromList [src | (NamedPort src _name, _ty) <- concat (M.elems captureSet)] in run g fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) (BratNode (PatternMatch (c:|cs)) _ _) -> run g (fz :< Alternatives (c:cs) ins) TryNextMatch + (BratNode (Constructor c) _ _) -> run g fz (Finished [evalConstructor c ins]) nw -> run g fz (StuckOnNode n nw) @@ -134,6 +135,23 @@ run g (fz :< BratValues _) t = run g fz t run g B0 t = t run g fz t = run g fz (Suspend [] t) +evalConstructor :: QualName -> [Value] -> Value +evalConstructor CTrue [] = BoolV True +evalConstructor CFalse [] = BoolV False +evalConstructor CZero [] = IntV 0 +evalConstructor CSucc [IntV n] = IntV (n + 1) +evalConstructor CDoub [IntV n] = IntV (2 * n) +evalConstructor CNil [] = VecV [] +evalConstructor CCons [hd, VecV tl] = VecV (hd:tl) +evalConstructor CSnoc [VecV tl, hd] = VecV (tl ++ [hd]) +evalConstructor CConcatEqEven [VecV ls, VecV rs] = VecV (ls ++ rs) +evalConstructor CRiffle [VecV evens, VecV odds] = VecV (riffle evens odds) + where + riffle [] [] = [] + riffle (e:es) (o:os) = e:o:riffle es os +evalConstructor CConcatEqOdd [VecV ls, mid, VecV rs] = VecV (ls ++ mid:rs) +evalConstructor _ _ = error "Internal error: Unhandled constructor" + doAllTests :: EvalEnv -> [(Src, PrimTest (BinderType Brat))] -> Maybe EvalEnv doAllTests env [] = Just env doAllTests env ((NamedPort outport _, test):tests) = diff --git a/brat/arith.brat b/brat/arith.brat index d6fdf5db..60eeeebc 100644 --- a/brat/arith.brat +++ b/brat/arith.brat @@ -31,7 +31,7 @@ hoo(succ(l), ls =, m ,= rs) = length(!, !, ls) hoo(n, _) = n ioo :: Nat -ioo = hoo(!, [1,2,3]) +ioo = hoo(2, [1,2,3]) joo :: Vec(Nat, 3) -joo = [1,2,3] \ No newline at end of file +joo = [1,2,3] From 5d235716cf07a04509d527439597989ea8ad7f50 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 11:40:06 +0000 Subject: [PATCH 051/149] WIP remove Brat-specific compilation --- brat/Brat/Compile/Hugr.hs | 136 +------------------------------------- 1 file changed, 2 insertions(+), 134 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 2bd81ec4..a9d0181a 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -193,30 +193,6 @@ compileConst parent tm ty = do addEdge (Port constId 0, Port loadId 0) pure loadId -compileArithNode :: NodeId -> ArithOp -> Val Z -> Compile NodeId -compileArithNode parent op TNat = addNode (show op ++ "_Nat") (parent, OpCustom $ case op of - Add -> binaryIntOp "iadd" - Sub -> binaryIntOp "isub" - Mul-> binaryIntOp "imul" - Div -> intOp "idiv_u" [hugrInt, hugrInt] [hugrInt] [TANat intWidth, TANat intWidth] - Pow -> error "TODO: Pow" -- Not defined in extension - ) -compileArithNode parent op TInt = addNode (show op ++ "_Int") (parent, OpCustom $ case op of - Add -> binaryIntOp "iadd" - Sub -> binaryIntOp "isub" - Mul-> binaryIntOp "imul" - Div -> intOp "idiv_u" [hugrInt, hugrInt] [hugrInt] [TANat intWidth, TANat intWidth] - Pow -> error "TODO: Pow" -- Not defined in extension - ) -compileArithNode parent op TFloat = addNode (show op ++ "_Float") (parent, OpCustom $ case op of - Add -> binaryFloatOp "fadd" - Sub -> binaryFloatOp "fsub" - Mul-> binaryFloatOp "fmul" - Div-> binaryFloatOp "fdiv" - Pow -> error "TODO: Pow" -- Not defined in extension - ) -compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty - dumpJSON :: Compile BS.ByteString dumpJSON = gets hugr <&> (encode . H.serialize) @@ -338,7 +314,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case let node = ns M.! name trackM ("compileNode (" ++ show parent ++ ") " ++ show name ++ " " ++ show node) nod_edge_info <- case node of - (BratNode thing ins outs) -> compileNode' thing ins outs + (BratNode _ _ _) -> error "Can't compile classical Brat" (KernelNode thing ins outs) -> compileNode' thing ins outs case nod_edge_info of Nothing -> pure Nothing @@ -349,7 +325,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case default_edges :: NodeId -> Maybe (NodeId, Int, [(PortId NodeId, Int)]) default_edges nid = Just (nid, 0, []) - compileNode' :: NodeType m -> [(PortName, Val Z)] -> [(PortName, Val Z)] + compileNode' :: NodeType Kernel -> [(PortName, Val Z)] -> [(PortName, Val Z)] -- Result is nodeid, port offset, *extra* edges -> Compile (Maybe (NodeId, Int, [(PortId NodeId, Int)])) compileNode' thing ins outs = case thing of @@ -374,70 +350,6 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case put (st { holes = h :< name}) pure (length h) addNode ("hole " ++ show hole) (parent, OpCustom (holeOp hole sig)) - -- A reference to a primitive op which exists in hugr. - -- This should only have one outgoing wire which leads to an `Id` node for - -- the brat representation of the function, and that wire should have a - -- function type - Prim (ext,op) -> do - let n = ext ++ ('_':op) - let [] = ins - -- TODO: Handle primitives which aren't functions - let [(_, VFun Braty cty)] = outs - boxSig@(inputTys, outputTys) <- compileSig Braty cty - let boxFunTy = FunctionType inputTys outputTys bratExts - ((Port loadConst _, _ty), ()) <- compileConstDfg parent n boxSig $ - \Ctr{parent, input, output} -> do - setOp input (OpIn (InputNode inputTys [("source", "Prim")])) - let ins = zip (Port input <$> [0..]) inputTys - outs <- addNodeWithInputs n (parent, OpCustom (CustomOp ext op boxFunTy [])) ins outputTys - setOp output (OpOut (OutputNode outputTys [("source", "Prim")])) - for_ (zip (fst <$> outs) (Port output <$> [0..])) addEdge - pure () - pure $ default_edges loadConst - - -- Check if the node has prefix "globals", hence should be a direct call - Eval tgt@(Ex outNode _) -> do - ins <- compilePorts ins - outs <- compilePorts outs - (ns, _) <- gets bratGraph - decls <- gets decls - case hasPrefix ["checking", "globals", "prim"] outNode of - -- Callee is a Prim node, insert Hugr Op; first look up outNode in the BRAT graph to get the Prim data - Just suffix -> default_edges <$> case M.lookup outNode ns of - Just (BratNode (Prim (ext,op)) _ _) -> do - addNode (show suffix) (parent, OpCustom (CustomOp ext op (FunctionType ins outs [ext]) [])) - x -> error $ "Expected a Prim node but got " ++ show x - Nothing -> case hasPrefix ["checking", "globals"] outNode of - -- Callee is a user-defined global def that, since it does not require an "extra" call, can be turned from IndirectCall to direct. - Just _ | (funcDef, False) <- fromJust (M.lookup outNode decls) -> do - callerId <- addNode ("direct_call(" ++ show funcDef ++ ")") - (parent, OpCall (CallOp (FunctionType ins outs bratExts))) - -- Add the static edge from the FuncDefn node to the port *after* - -- all of the dynamic arguments to the Call node. - -- This is because in hugr, static edges (like the graph arg to a - -- Call) come after dynamic edges - pure $ Just (callerId, 0, [(Port funcDef 0, length ins)]) - -- Either not global, or we must evaluate the global -- so an indirect call of a graph on a wire - -- (If it's a global, compileWithInputs will generate extra no-args Call, - -- since extra_call==True; we just turned the (Eval+)LoadFunction case into a direct Call above) - _ -> getOutPort parent tgt >>= \case - Just funcPort@(Port calleeId _) -> do - callerId <- addNode ("indirect_call(" ++ show calleeId ++ ")") - (parent, OpCallIndirect (CallIndirectOp (FunctionType ins outs bratExts {-[]-}))) - -- for an IndirectCall, the callee (thunk, function value) is the *first* - -- Hugr input. So move all the others along, and add that extra edge. - pure $ Just (callerId, 1, [(funcPort, 0)]) - Nothing -> error "Callee has been erased" - - -- We need to figure out if this thunk contains a brat- or a kernel-computation - (Box src tgt) -> case outs of - [(_, VFun Kerny cty)] -> default_edges . nodeId . fst <$> - compileKernBox parent (show name) (src, tgt) cty - [(_, VFun Braty cty)] -> do - cs <- gets (M.findWithDefault M.empty name . capSets) - (partialNode, captures) <- compileBratBox parent name (cs, src, tgt) cty - pure $ Just (partialNode, 1, captures) -- 1 is arbitrary, Box has no real inputs - outs -> error $ "Unexpected outs of box: " ++ show outs Source -> error "Source found outside of compileBox" @@ -464,14 +376,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case setOp outputNode (OpOut (OutputNode (snd <$> ccOuts) [("source", "PatternMatch"), ("parent", show dfgId)])) for_ (zip (fst <$> ccOuts) (Port outputNode <$> [0..])) addEdge pure dfgId - ArithNode op -> default_edges <$> compileArithNode parent op (snd $ head ins) Selector _c -> error "Todo: selector" - Replicate -> default_edges <$> do - ins <- compilePorts ins - let [_, elemTy] = ins - outs <- compilePorts outs - let sig = FunctionType ins outs bratExts - addNode "Replicate" (parent, OpCustom (CustomOp "BRAT" "Replicate" sig [TAType elemTy])) x -> error $ show x ++ " should have been compiled outside of compileNode" compileConstructor :: NodeId -> QualName -> QualName -> FunctionType -> Compile NodeId @@ -524,43 +429,6 @@ compileConstDfg parent desc (inTys, outTys) contents = do [(Port constNode 0, ht)] [ht] pure (lcPort, a) --- Brat computations may capture some local variables. Thus, we need --- to lambda-lift, producing (as results) a Partial node and a list of --- extra arguments i.e. the captured values -compileBratBox :: NodeId -> Name -> (VEnv, Name, Name) -> CTy Brat Z -> Compile (NodeId, [(PortId NodeId, Int)]) -compileBratBox parent name (venv, src, tgt) cty = do - -- we'll "Partial" over every value in the environment. - -- (TODO in the future capture which ones are actually used in the sub-hugr. We may need - -- to put captured values after the original params, and have a reversed Partial.) - let params :: [(OutPort, BinderType Brat)] = map (first end) (concat $ M.elems venv) - parmTys <- compileGraphTypes (map (binderToValue Braty . snd) params) - - -- Create a FuncDefn for the lambda that takes the params as first inputs - (inputTys, outputTys) <- compileSig Braty cty - let allInputTys = parmTys ++ inputTys - let boxInnerSig = FunctionType allInputTys outputTys bratExts - - (templatePort, _) <- compileConstDfg parent ("BB" ++ show name) (allInputTys, outputTys) $ - -- ideally would name the Input "LiftedCapturedInputs" - \Ctr {parent, input = src_id, output} -> do - setOp src_id (OpIn (InputNode allInputTys [("source", "compileBratBox")])) - -- Now map ports in the BRAT Graph to their Hugr equivalents. - -- Each captured value is read from an element of src_id, starting from 0 - let lifted = [(src, Port src_id i) | ((src, _ty), i) <- zip params [0..]] - -- and the original BRAT-Graph Src outports become the Hugr Input node ports *after* the captured values - ++ [(Ex src i, Port src_id (i + length params)) | i <- [0..length inputTys]] - st <- get - put $ st {liftedOutPorts = M.fromList lifted} - -- no need to return any holes - compileTarget parent output tgt - - -- Finally, we add a `Partial` node to supply the captured params. - partialNode <- addNode "Partial" (parent, OpCustom $ partialOp boxInnerSig (length params)) - addEdge (fst templatePort, Port partialNode 0) - edge_srcs <- for (map fst params) $ getOutPort parent - pure (partialNode, zip (map fromJust edge_srcs) [1..]) - -- error on Nothing, the Partial is expecting a value - compileKernBox :: NodeId -> String -> (Name, Name) -> CTy Kernel Z -> Compile TypedPort compileKernBox parent desc src_tgt cty = do -- compile kernel nodes only into a Hugr with "Holes" From 5bcc324d7c9c941c087cfeba9ace6ae01d08aead Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 12:54:03 +0000 Subject: [PATCH 052/149] And a bit more --- brat/Brat/Compile/Hugr.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index a9d0181a..3c9c3ba8 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -691,9 +691,7 @@ compileModule venv moduleNode = do -- All top-level functions are compiled into Box-es, which should look like this: [(Ex input 0, _)] | Just (BratNode (Box src tgt) _ outs) <- M.lookup input ns -> case outs of - [(_, VFun Braty cty)] -> do - (inTys, outTys) <- compileSig Braty cty - pure (PolyFuncType [] (FunctionType inTys outTys bratExts), False, flip compileBox (src, tgt)) + [(_, VFun Braty cty)] -> error "Can't compile classical Brat" [(_, VFun Kerny cty)] -> do -- We're compiling, e.g. -- f :: { Qubit -o Qubit } From d2676c8f8d20b2bb82fc51d1edd589034f60610e Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 12:31:31 +0000 Subject: [PATCH 053/149] Simplify: all decls require extra-call --- brat/Brat/Compile/Hugr.hs | 42 ++++++++++++++------------------------- 1 file changed, 15 insertions(+), 27 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 3c9c3ba8..1ffbaa7c 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -62,11 +62,11 @@ data CompilationState = CompilationState , holes :: Bwd Name -- for Kernel graphs, list of Splices found in order , store :: Store -- Kinds and values of global variables, for compiling types -- A map from Id nodes representing functions and values in the brat graph, - -- to the FuncDef nodes that we create for them. The bool, if true, says that - -- we must insert an *extra* call, beyond what's required in Brat, to compute the value + -- to the FuncDef nodes that we create for them. Each of these will need an + -- *extra* call, beyond what's required in Brat, to compute the value -- of the decl (e.g. `x :: Int` `x = 1+2` requires calling the FuncDefn to calculate 1+2). -- Note that in the future this could be extended to allow top-level Consts too. - , decls :: M.Map Name (NodeId, Bool) + , decls :: M.Map Name NodeId } type Compile = State CompilationState @@ -93,7 +93,7 @@ makeCS (g, cs, store) hugr = , decls = M.empty } -registerFuncDef :: Name -> (NodeId, Bool) -> Compile () +registerFuncDef :: Name -> NodeId -> Compile () registerFuncDef name hugrDef = do st <- get put (st { decls = M.insert name hugrDef (decls st) }) @@ -292,21 +292,9 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case hTys <- in_edges name <&> (map (compileType . snd . fst) . sortBy (comparing snd)) decls <- gets decls - let (funcDef, extra_call) = decls M.! name - nod <- if extra_call - then addNode ("direct_call(" ++ show funcDef ++ ")") - (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) - -- We are loading idNode as a value (not an Eval'd thing), and it is a FuncDef directly - -- corresponding to a Brat TLD (not that produces said TLD when eval'd) - else case hTys of - [HTFunc poly@(PolyFuncType [] _)] -> - addNode ("load_thunk(" ++ show funcDef ++ ")") - (parent, OpLoadFunction (LoadFunctionOp poly [] (FunctionType [] [HTFunc poly] []))) - [HTFunc (PolyFuncType args _)] -> error $ unwords ["Unexpected type args to" - ,show funcDef ++ ":" - ,show args - ] - _ -> error $ "Expected a function argument when loading thunk, got: " ++ show hTys + let funcDef = decls M.! name + nod <- addNode ("direct_call(" ++ show funcDef ++ ")") + (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) -- the only input pure $ Just (nod, [(Port funcDef 0, 0)]) _ -> do @@ -664,10 +652,10 @@ compileModule venv moduleNode = do -- Prepare FuncDef nodes for all functions. Every "noun" also requires a Function -- to compute its value. bodies <- for decls (\(fnName, idNode) -> do - (funTy, extra_call, body) <- analyseDecl idNode + (funTy, body) <- analyseDecl idNode ctr@Ctr {parent} <- freshNodeWithIO (show fnName ++ "_def") moduleNode setOp parent (OpDefn $ FuncDefn (show fnName) funTy []) - registerFuncDef idNode (parent, extra_call) + registerFuncDef idNode parent pure (body ctr) ) for_ bodies (\body -> do @@ -680,10 +668,10 @@ compileModule venv moduleNode = do body) where -- Given the Brat-Graph Id node for the decl, work out how to compile it (later); - -- return the type of the Hugr FuncDefn, whether said FuncDefn requires an extra Call, - -- and the procedure for compiling the contents of the FuncDefn for execution later, - -- *after* all such FuncDefns have been registered - analyseDecl :: Name -> Compile (PolyFuncType, Bool, Container -> Compile ()) + -- return the type of the Hugr FuncDefn, and the procedure for compiling the + -- contents of the FuncDefn for execution later, *after* all such FuncDefns have + -- been registered + analyseDecl :: Name -> Compile (PolyFuncType, Container -> Compile ()) analyseDecl idNode = do (ns, es) <- gets bratGraph let srcPortTys = [(srcPort, ty) | (srcPort, ty, In tgt _) <- es, tgt == idNode ] @@ -700,7 +688,7 @@ compileModule venv moduleNode = do -- computation that produces this constant. We do so by making a FuncDefn -- that takes no arguments and produces the constant kernel graph value. thunkTy <- HTFunc . PolyFuncType [] . (\(ins, outs) -> FunctionType ins outs bratExts) <$> compileSig Kerny cty - pure (funcReturning [thunkTy], True, \Ctr {parent, input, output} -> do + pure (funcReturning [thunkTy], \Ctr {parent, input, output} -> do setOp input (OpIn (InputNode [] [("source", "analyseDecl")])) setOp output (OpOut (OutputNode [thunkTy] [("source", "analyseDecl")])) wire <- compileKernBox parent (show input) (src, tgt) cty @@ -708,7 +696,7 @@ compileModule venv moduleNode = do _ -> error "Box should have exactly one output of Thunk type" _ -> do -- a computation, or several values outs <- compilePorts srcPortTys -- note compiling already-erased types, is this right? - pure (funcReturning outs, True, compileNoun outs (map fst srcPortTys)) + pure (funcReturning outs, compileNoun outs (map fst srcPortTys)) -- top-level decls that are not Prims. RHS is the brat idNode decls :: [(QualName, Name)] From c5e303659016f8eefe9c2299f8981ede48dcb816 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 13:38:27 +0000 Subject: [PATCH 054/149] WIP expose only compileKernel, fix holes. direct calls WTF?? --- brat/Brat/Compile/Hugr.hs | 195 +++++++++++--------------------------- 1 file changed, 54 insertions(+), 141 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 1ffbaa7c..0e1bc81b 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -7,7 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} -module Brat.Compile.Hugr (compile) where +module Brat.Compile.Hugr (compileKernel) where import Brat.Constructors.Patterns (pattern CFalse, pattern CTrue) import Brat.Checker.Monad (track, trackM, CheckingSig(..), CaptureSets) @@ -59,7 +59,7 @@ data CompilationState = CompilationState -- This maps from the captured value (in the BRAT graph, perhaps outside the current func/lambda) -- to the Hugr port capturing it in the current context. , liftedOutPorts :: M.Map OutPort (PortId NodeId) - , holes :: Bwd Name -- for Kernel graphs, list of Splices found in order + , holes :: Bwd (NodeId, OutPort) -- where to splice in result of another Brat computation , store :: Store -- Kinds and values of global variables, for compiling types -- A map from Id nodes representing functions and values in the brat graph, -- to the FuncDef nodes that we create for them. Each of these will need an @@ -120,6 +120,16 @@ addNode nam (parent, op) = do setOp name (addMetadata [("id", show name)] op) pure name +-- Add a hole, record that it should be filled from the specified OutPort +addHole :: NodeId -> FunctionType -> OutPort -> Compile NodeId +addHole parent sig outPort = do + -- hole index is not important now, we identify holes by NodeId + hole <- gets (length . holes) -- but anyway + h <- addNode ("hole " ++ show hole) (parent, OpCustom (holeOp hole sig)) + st <- get + put (st { holes = (holes st) :< (h, outPort)}) + pure h + runCheckingInCompile :: Free CheckingSig t -> Compile t runCheckingInCompile (Ret t) = pure t runCheckingInCompile (Req (ELup e) k) = do @@ -291,12 +301,19 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case -- Note this is where we must compile something different *for each caller* by clearing out the `compiled` map for each function hTys <- in_edges name <&> (map (compileType . snd . fst) . sortBy (comparing snd)) + -- ALAN do we do this? Or rather than call a function (returning a kernel thunk), + -- do we make a hole so that the interpreter splices in the kernel thunk as a Hugr? decls <- gets decls let funcDef = decls M.! name nod <- addNode ("direct_call(" ++ show funcDef ++ ")") (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) -- the only input pure $ Just (nod, [(Port funcDef 0, 0)]) + -- ALAN or ??? if this is right, can remove decls altogether + let name = undefined -- is name an idNode? Take it's input? + nod <- addHole parent (FunctionType [] hTys bratExts) (Ex name 0) + pure $ Just (nod, []) -- no edges?? Need one edge in/out per arg/return? + --Maybe this doesn't happen in kernels since we don't do indirect calls? _ -> do (ns, _) <- gets bratGraph let node = ns M.! name @@ -318,7 +335,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case -> Compile (Maybe (NodeId, Int, [(PortId NodeId, Int)])) compileNode' thing ins outs = case thing of Const tm -> default_edges <$> (compilePorts outs >>= (compileConst parent tm . head)) - Splice (Ex outNode _) -> default_edges <$> do + Splice outPort@(Ex outNode _) -> default_edges <$> do ins <- compilePorts ins outs <- compilePorts outs let sig = FunctionType ins outs bratExts @@ -331,13 +348,8 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case addNode (show suffix) (parent, OpCustom (CustomOp ext op sig [])) x -> error $ "Expected a Prim kernel node but got " ++ show x -- All other evaled things are turned into holes to be substituted later - Nothing -> do - hole <- do - st <- get - let h = holes st - put (st { holes = h :< name}) - pure (length h) - addNode ("hole " ++ show hole) (parent, OpCustom (holeOp hole sig)) + + Nothing -> addHole parent sig outPort Source -> error "Source found outside of compileBox" @@ -393,56 +405,6 @@ getOutPort parent p@(Ex srcNode srcPort) = do Just intercept -> pure $ Just intercept Nothing -> compileWithInputs parent srcNode <&> (\maybe -> maybe <&> flip Port srcPort) --- Execute a compilation (which takes a DFG parent) in a nested monad; --- produce a Const node containing the resulting Hugr, and a LoadConstant, --- and return the latter. -compileConstDfg :: NodeId -> String -> ([HugrType], [HugrType]) -> (Container -> Compile a) -> Compile (TypedPort, a) -compileConstDfg parent desc (inTys, outTys) contents = do - st <- gets store - g <- gets bratGraph - cs <- gets capSets - let funTy = FunctionType inTys outTys bratExts - -- First, we fork off a new namespace - nsx <- onHugr (H.splitNamespace desc) - -- And pass that namespace into nested monad that compiles the DFG - let boxdesc = "Box_" ++ desc - let h = H.new nsx boxdesc (OpDFG $ DFG funTy []) - let (a, compState) = runState (makeIO boxdesc (root h) >>= contents) - (makeCS (g,cs,st) h) - let nestedHugr = H.serialize (hugr compState) - let ht = HTFunc $ PolyFuncType [] funTy - - constNode <- addNode ("ConstTemplate_" ++ desc) (parent, OpConst (ConstOp (HVFunction nestedHugr))) - lcPort <- head <$> addNodeWithInputs ("LoadTemplate_" ++ desc) (parent, OpLoadConstant (LoadConstantOp ht)) - [(Port constNode 0, ht)] [ht] - pure (lcPort, a) - -compileKernBox :: NodeId -> String -> (Name, Name) -> CTy Kernel Z -> Compile TypedPort -compileKernBox parent desc src_tgt cty = do - -- compile kernel nodes only into a Hugr with "Holes" - -- when we see a Splice, we'll record the func-port onto a list - -- return a Hugr with holes - boxInnerSig@(inTys, outTys) <- compileSig Kerny cty - let boxTy = HTFunc $ PolyFuncType [] (FunctionType inTys outTys bratExts) - (templatePort, holelist) <- compileConstDfg parent ("KB" ++ desc) boxInnerSig $ \ctr -> do - compileBox ctr src_tgt - gets holes - - -- For each hole in the template (index 0 i.e. earliest, first) - -- compile the kernel that should be spliced in and record its signature. - ns <- gets (fst . bratGraph) - hole_ports <- for (holelist <>> []) (\splice -> do - let (KernelNode (Splice kernel_src) ins outs) = ns M.! splice - ins <- compilePorts ins - outs <- compilePorts outs - kernel_src <- getOutPort parent kernel_src <&> fromJust - pure (kernel_src, HTFunc (PolyFuncType [] (FunctionType ins outs bratExts)))) - - -- Add a substitute node to fill the holes in the template - let hole_sigs = [ body poly | (_, HTFunc poly) <- hole_ports ] - head <$> addNodeWithInputs ("subst_" ++ desc) (parent, OpCustom (substOp (FunctionType inTys outTys bratExts) hole_sigs)) (templatePort : hole_ports) [boxTy] - - -- We get a bunch of TypedPorts which are associated with Srcs in the BRAT graph. -- Then, we'll perform a sequence of matches on those ports -- Return a sum whose first component is the types we started with in the order @@ -645,58 +607,38 @@ undoPrimTest parent inPorts outTy (PrimLitTest tm) = do head <$> addNodeWithInputs "LitLoad" (parent, OpLoadConstant (LoadConstantOp outTy)) [(Port constId 0, outTy)] [outTy] --- Create a module and FuncDecl nodes inside it for all of the functions given as argument -compileModule :: VEnv -> NodeId - -> Compile () -compileModule venv moduleNode = do - -- Prepare FuncDef nodes for all functions. Every "noun" also requires a Function - -- to compute its value. - bodies <- for decls (\(fnName, idNode) -> do - (funTy, body) <- analyseDecl idNode - ctr@Ctr {parent} <- freshNodeWithIO (show fnName ++ "_def") moduleNode - setOp parent (OpDefn $ FuncDefn (show fnName) funTy []) - registerFuncDef idNode parent - pure (body ctr) - ) - for_ bodies (\body -> do - st <- get - -- At the start of each function, clear out the `compiled` map - these are - -- the nodes compiled (usable) within that function. Generally Brat-graph nodes - -- are only reachable from one TLD, but the `Id` nodes are shared, and must have - -- their own LoadConstant/extra-Call/etc. *within each function*. - put st { compiled = M.empty } - body) - where - -- Given the Brat-Graph Id node for the decl, work out how to compile it (later); - -- return the type of the Hugr FuncDefn, and the procedure for compiling the - -- contents of the FuncDefn for execution later, *after* all such FuncDefns have - -- been registered - analyseDecl :: Name -> Compile (PolyFuncType, Container -> Compile ()) - analyseDecl idNode = do - (ns, es) <- gets bratGraph - let srcPortTys = [(srcPort, ty) | (srcPort, ty, In tgt _) <- es, tgt == idNode ] - case srcPortTys of +compileKernel :: (Namespace, Store, Graph, CaptureSets) + -> VEnv -> String -> Name + -> (BS.ByteString, [(NodeId, OutPort)]) +compileKernel (nsp, store, g@(ns, es), cs) venv desc name = (hugr, holelist) where + (src_tgt, outs) = case ns M.! name of + (BratNode Id _ _) -> case [srcPort | (srcPort, _, In tgt _) <- es, tgt == name ] of -- All top-level functions are compiled into Box-es, which should look like this: - [(Ex input 0, _)] | Just (BratNode (Box src tgt) _ outs) <- M.lookup input ns -> - case outs of - [(_, VFun Braty cty)] -> error "Can't compile classical Brat" - [(_, VFun Kerny cty)] -> do - -- We're compiling, e.g. - -- f :: { Qubit -o Qubit } - -- f = { h; circ(pi) } - -- Although this looks like a constant kernel, we'll have to compile the - -- computation that produces this constant. We do so by making a FuncDefn - -- that takes no arguments and produces the constant kernel graph value. - thunkTy <- HTFunc . PolyFuncType [] . (\(ins, outs) -> FunctionType ins outs bratExts) <$> compileSig Kerny cty - pure (funcReturning [thunkTy], \Ctr {parent, input, output} -> do - setOp input (OpIn (InputNode [] [("source", "analyseDecl")])) - setOp output (OpOut (OutputNode [thunkTy] [("source", "analyseDecl")])) - wire <- compileKernBox parent (show input) (src, tgt) cty - addEdge (fst wire, Port output 0)) - _ -> error "Box should have exactly one output of Thunk type" - _ -> do -- a computation, or several values - outs <- compilePorts srcPortTys -- note compiling already-erased types, is this right? - pure (funcReturning outs, compileNoun outs (map fst srcPortTys)) + [Ex input 0] | Just (BratNode (Box src tgt) [] outs) <- M.lookup input ns -> ((src, tgt), outs) + (BratNode (Box src tgt) [] outs) -> ((src, tgt), outs) + nt -> error $ "Can only compile Box nodes or Id from them, not " ++ show nt ++ " (for " ++ show name ++ ")" + cty = case outs of + [(_, VFun Kerny cty)] -> cty + startHugr = H.new nsp desc (OpDFG $ DFG (FunctionType hInTys hOutTys bratExts) []) + (hugr, holelist) = flip evalState (makeCS (g,cs,store) startHugr) $ do + bodies <- for decls $ \(fnName, idNode) -> do + let moduleNod = undefined + --(funTy, body) <- analyseDecl idNode + ctr@Ctr {parent} <- freshNodeWithIO (show fnName ++ "_def") moduleNod + --setOp parent (OpDefn $ FuncDefn (show fnName) funTy []) + registerFuncDef idNode parent + ctr <- makeIO desc (root startHugr) + compileBox ctr src_tgt + json <- dumpJSON + hs <- gets holes + pure (json, hs <>> []) + + (hInTys, hOutTys) = runLocalChecking (evalCTy S0 Kerny cty <&> (\(ss :->> ts) -> (compileRo ss, compileRo ts))) + + runLocalChecking :: Free CheckingSig t -> t + runLocalChecking (Ret t) = t + runLocalChecking (Req (ELup e) k) = runLocalChecking (k (M.lookup e (valueMap store))) + runLocalChecking (Req _ _) = error "Compile monad found a command it can't handle" -- top-level decls that are not Prims. RHS is the brat idNode decls :: [(QualName, Name)] @@ -705,33 +647,4 @@ compileModule venv moduleNode = do let (Ex idNode _) = end (fst $ head wires) -- would be better to check same for all rather than just head case hasPrefix ["checking","globals","decl"] idNode of Just _ -> pure (fnName, idNode) -- assume all ports are 0,1,2... - Nothing -> [] - - funcReturning :: [HugrType] -> PolyFuncType - funcReturning outs = PolyFuncType [] (FunctionType [] outs bratExts) - -compileNoun :: [HugrType] -> [OutPort] -> Container -> Compile () -compileNoun outs srcPorts Ctr {parent, input, output} = do - setOp input (OpIn (InputNode [] [("source", "compileNoun")])) - setOp output (OpOut (OutputNode outs [("source", "compileNoun")])) - for_ (zip [0..] srcPorts) (\(outport, Ex src srcPort) -> - compileWithInputs parent src >>= \case - Just nodeId -> addEdge (Port nodeId srcPort, Port output outport) $> () - Nothing -> pure () -- if input not compilable, leave edge missing in Hugr - or just error? - ) - -compile :: Store - -> Namespace - -> Graph - -> CaptureSets - -> VEnv - -> BS.ByteString -compile store ns g capSets venv = - let hugr = H.new ns "module" (OpMod ModuleOp) - in evalState - (trackM "compileFunctions" *> - compileModule venv (root hugr) *> - trackM "dumpJSON" *> - dumpJSON - ) - (makeCS (g, capSets, store) hugr) + Nothing -> [] \ No newline at end of file From 8b937fe3549202b7f7ebcb33c29560a4227d0b58 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 19:24:30 +0000 Subject: [PATCH 055/149] Remove CaptureSets --- brat/Brat/Compile/Hugr.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 0e1bc81b..6a9329e7 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -52,7 +52,6 @@ type TypedPort = (PortId NodeId, HugrType) data CompilationState = CompilationState { bratGraph :: Graph -- the input BRAT Graph; should not be written - , capSets :: CaptureSets -- environments captured by Box nodes in previous , hugr :: HugrGraph , compiled :: M.Map Name NodeId -- Mapping from Brat nodes to Hugr nodes -- When lambda lifting, captured variables become extra function inputs. @@ -80,11 +79,10 @@ data Container = Ctr { output :: NodeId } -makeCS :: (Graph, CaptureSets, Store) -> HugrGraph -> CompilationState -makeCS (g, cs, store) hugr = +makeCS :: (Graph, Store) -> HugrGraph -> CompilationState +makeCS (g, store) hugr = CompilationState { bratGraph = g - , capSets = cs , hugr = hugr , compiled = M.empty , holes = B0 @@ -607,10 +605,10 @@ undoPrimTest parent inPorts outTy (PrimLitTest tm) = do head <$> addNodeWithInputs "LitLoad" (parent, OpLoadConstant (LoadConstantOp outTy)) [(Port constId 0, outTy)] [outTy] -compileKernel :: (Namespace, Store, Graph, CaptureSets) +compileKernel :: (Namespace, Store, Graph) -> VEnv -> String -> Name -> (BS.ByteString, [(NodeId, OutPort)]) -compileKernel (nsp, store, g@(ns, es), cs) venv desc name = (hugr, holelist) where +compileKernel (nsp, store, g@(ns, es)) venv desc name = (hugr, holelist) where (src_tgt, outs) = case ns M.! name of (BratNode Id _ _) -> case [srcPort | (srcPort, _, In tgt _) <- es, tgt == name ] of -- All top-level functions are compiled into Box-es, which should look like this: @@ -620,7 +618,7 @@ compileKernel (nsp, store, g@(ns, es), cs) venv desc name = (hugr, holelist) whe cty = case outs of [(_, VFun Kerny cty)] -> cty startHugr = H.new nsp desc (OpDFG $ DFG (FunctionType hInTys hOutTys bratExts) []) - (hugr, holelist) = flip evalState (makeCS (g,cs,store) startHugr) $ do + (hugr, holelist) = flip evalState (makeCS (g,store) startHugr) $ do bodies <- for decls $ \(fnName, idNode) -> do let moduleNod = undefined --(funTy, body) <- analyseDecl idNode From 34ed0634dd77a60a536e9f16f9919a56dbf679df Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 19:25:25 +0000 Subject: [PATCH 056/149] Ah - kernels were inside Value::Constants, so could never have called TLDs. Rm decls! --- brat/Brat/Compile/Hugr.hs | 51 +++------------------------------------ 1 file changed, 3 insertions(+), 48 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 6a9329e7..1321ee7e 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -60,12 +60,6 @@ data CompilationState = CompilationState , liftedOutPorts :: M.Map OutPort (PortId NodeId) , holes :: Bwd (NodeId, OutPort) -- where to splice in result of another Brat computation , store :: Store -- Kinds and values of global variables, for compiling types - -- A map from Id nodes representing functions and values in the brat graph, - -- to the FuncDef nodes that we create for them. Each of these will need an - -- *extra* call, beyond what's required in Brat, to compute the value - -- of the decl (e.g. `x :: Int` `x = 1+2` requires calling the FuncDefn to calculate 1+2). - -- Note that in the future this could be extended to allow top-level Consts too. - , decls :: M.Map Name NodeId } type Compile = State CompilationState @@ -88,14 +82,8 @@ makeCS (g, store) hugr = , holes = B0 , liftedOutPorts = M.empty , store = store - , decls = M.empty } -registerFuncDef :: Name -> NodeId -> Compile () -registerFuncDef name hugrDef = do - st <- get - put (st { decls = M.insert name hugrDef (decls st) }) - freshNode :: String -> NodeId -> Compile NodeId freshNode name parent = onHugr (H.freshNode parent name) @@ -293,25 +281,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case -- Otherwise, NodeId of compiled node, and list of Hugr in-edges (source and target-port) compileNode :: Compile (Maybe (NodeId, [(PortId NodeId, Int)])) compileNode = case (hasPrefix ["checking", "globals", "decl"] name) of - Just _ -> do - -- reference to a top-level decl. Every such should be in the decls map. - -- We need to return value of each type (perhaps to be indirectCalled by successor). - -- Note this is where we must compile something different *for each caller* by clearing out the `compiled` map for each function - hTys <- in_edges name <&> (map (compileType . snd . fst) . sortBy (comparing snd)) - - -- ALAN do we do this? Or rather than call a function (returning a kernel thunk), - -- do we make a hole so that the interpreter splices in the kernel thunk as a Hugr? - decls <- gets decls - let funcDef = decls M.! name - nod <- addNode ("direct_call(" ++ show funcDef ++ ")") - (parent, OpCall (CallOp (FunctionType [] hTys bratExts))) - -- the only input - pure $ Just (nod, [(Port funcDef 0, 0)]) - -- ALAN or ??? if this is right, can remove decls altogether - let name = undefined -- is name an idNode? Take it's input? - nod <- addHole parent (FunctionType [] hTys bratExts) (Ex name 0) - pure $ Just (nod, []) -- no edges?? Need one edge in/out per arg/return? - --Maybe this doesn't happen in kernels since we don't do indirect calls? + Just _ -> error "Kernel contained call to global; should have been a splice" _ -> do (ns, _) <- gets bratGraph let node = ns M.! name @@ -606,9 +576,9 @@ undoPrimTest parent inPorts outTy (PrimLitTest tm) = do [(Port constId 0, outTy)] [outTy] compileKernel :: (Namespace, Store, Graph) - -> VEnv -> String -> Name + -> String -> Name -> (BS.ByteString, [(NodeId, OutPort)]) -compileKernel (nsp, store, g@(ns, es)) venv desc name = (hugr, holelist) where +compileKernel (nsp, store, g@(ns, es)) desc name = (hugr, holelist) where (src_tgt, outs) = case ns M.! name of (BratNode Id _ _) -> case [srcPort | (srcPort, _, In tgt _) <- es, tgt == name ] of -- All top-level functions are compiled into Box-es, which should look like this: @@ -619,12 +589,6 @@ compileKernel (nsp, store, g@(ns, es)) venv desc name = (hugr, holelist) where [(_, VFun Kerny cty)] -> cty startHugr = H.new nsp desc (OpDFG $ DFG (FunctionType hInTys hOutTys bratExts) []) (hugr, holelist) = flip evalState (makeCS (g,store) startHugr) $ do - bodies <- for decls $ \(fnName, idNode) -> do - let moduleNod = undefined - --(funTy, body) <- analyseDecl idNode - ctr@Ctr {parent} <- freshNodeWithIO (show fnName ++ "_def") moduleNod - --setOp parent (OpDefn $ FuncDefn (show fnName) funTy []) - registerFuncDef idNode parent ctr <- makeIO desc (root startHugr) compileBox ctr src_tgt json <- dumpJSON @@ -637,12 +601,3 @@ compileKernel (nsp, store, g@(ns, es)) venv desc name = (hugr, holelist) where runLocalChecking (Ret t) = t runLocalChecking (Req (ELup e) k) = runLocalChecking (k (M.lookup e (valueMap store))) runLocalChecking (Req _ _) = error "Compile monad found a command it can't handle" - - -- top-level decls that are not Prims. RHS is the brat idNode - decls :: [(QualName, Name)] - decls = do -- in list monad, no Compile here - (fnName, wires) <- M.toList venv - let (Ex idNode _) = end (fst $ head wires) -- would be better to check same for all rather than just head - case hasPrefix ["checking","globals","decl"] idNode of - Just _ -> pure (fnName, idNode) -- assume all ports are 0,1,2... - Nothing -> [] \ No newline at end of file From 12c14c9efd9722954dd2a51f48905e3687c534d7 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 18:35:25 +0000 Subject: [PATCH 057/149] compile only kernel boxes, return map name -> bytes+[splice]; many invalid --- brat/Brat/Compiler.hs | 29 ++++++++++++++++------ brat/test/Test/Compile/Hugr.hs | 44 +++++++++++++++++----------------- 2 files changed, 44 insertions(+), 29 deletions(-) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index 0eb95dfc..f0f166ff 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -7,18 +7,25 @@ module Brat.Compiler (printAST ,CompilingHoles(..) ) where -import Brat.Checker.Types (TypedHole) +import Brat.Checker.Types (TypedHole, Modey(Kerny)) import Brat.Compile.Hugr import Brat.Dot (toDotString) import Brat.Elaborator import Brat.Error +import Brat.Graph(Node(BratNode), NodeType(Box)) import Brat.Load -import Brat.Naming (Namespace, root, split) +import Brat.Naming (Namespace, root, split, Name) +import Brat.Syntax.Port (OutPort) +import Brat.Syntax.Value (Val(VFun)) + import Control.Exception (evaluate) import Control.Monad (when) import Control.Monad.Except import qualified Data.ByteString.Lazy as BS +import Data.Foldable (for_) +import Data.HugrGraph (NodeId) +import qualified Data.Map as M import System.Exit (die) printDeclsHoles :: [FilePath] -> String -> IO () @@ -78,15 +85,23 @@ compileToGraph libDirs file = do env <- runExceptT $ loadFilename checkRoot libDirs file (newRoot,) <$> eitherIO env -compileFile :: [FilePath] -> String -> IO (Either CompilingHoles BS.ByteString) +-- Map from box name to (compiled bytes, list of splices) +-- TODO: should keep Hugr as struct not ByteString +type CompilationResult = M.Map Name (BS.ByteString, [(NodeId, OutPort)]) + +compileFile :: [FilePath] -> String -> IO (Either CompilingHoles CompilationResult) compileFile libDirs file = do - (newRoot, (venv, _, holes, defs, outerGraph, capSets)) <- compileToGraph libDirs file + (newRoot, (_, _, holes, st, outerGraph, _)) <- compileToGraph libDirs file case holes of - [] -> Right <$> evaluate -- turns 'error' into IO 'die' - (compile defs newRoot outerGraph capSets venv) + [] -> let boxes :: [Name] = [n | (n, BratNode (Box _ _) [] [(_, VFun Kerny _)]) <- (M.toList $ fst outerGraph)] + in Right <$> (evaluate -- turns 'error' into IO 'die' + $ M.fromList [(n, compileKernel (newRoot, st, outerGraph) "root" n) | n <- boxes]) hs -> pure $ Left (CompilingHoles hs) compileAndPrintFile :: [FilePath] -> String -> IO () compileAndPrintFile libDirs file = compileFile libDirs file >>= \case - Right bs -> BS.putStr bs + Right hs -> for_ (M.toList hs) $ \(n, (bs, splices)) -> do + putStrLn $ "Compiled box: " ++ show n + BS.putStr bs + putStrLn $ "With splices: " ++ show splices Left err -> die (show err) diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 2527d746..cae4fba1 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -1,11 +1,14 @@ module Test.Compile.Hugr where +import Control.Monad (forM) + import Brat.Compiler (compileFile, CompilingHoles(..)) import Test.Checking (expectedCheckingFails) import Test.Parsing (expectedParsingFails) import Test.Util (expectFailForPaths) import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as M import System.Directory (createDirectoryIfMissing) import System.FilePath import Test.Tasty @@ -35,40 +38,37 @@ invalidExamples = (map ((++ ".brat") . ("examples" )) -- Note this does not include those with remaining holes; these are automatically skipped. nonCompilingExamples = expectedCheckingFails ++ expectedParsingFails ++ map ((++ ".brat") . ("examples" )) - ["fzbz" - ,"ising" - ,"let" - ,"patterns" - ,"qft" - ,"infer" -- problems with undoing pattern tests - ,"infer2" -- problems with undoing pattern tests + [--"fzbz" -- can compile just kernels + --,"ising" -- can compile just kernels + --,"let" -- can compile just kernels + --,"patterns" -- can compile just kernels + "qft" + --,"infer" -- problems with undoing pattern tests -- can compile just kernels + --,"infer2" -- problems with undoing pattern tests -- can compile just kernels ,"fanout" -- Contains Selectors - ,"vectorise" -- Generates MapFun nodes which aren't implemented yet - ,"vector_solve" -- Generates "Pow" nodes which aren't implemented yet - ,"batcher-merge-sort" -- Generates MapFun nodes which aren't implemented yet + --,"vectorise" -- Generates MapFun nodes which aren't implemented yet -- can compile just kernels + --,"vector_solve" -- Generates "Pow" nodes which aren't implemented yet -- can compile just kernels + --,"batcher-merge-sort" -- Generates MapFun nodes which aren't implemented yet -- can compile just kernels -- Victims of #13 - ,"arith" + --,"arith" -- can compile just kernels ,"cqcconf" ,"imports" - ,"ising" ,"klet" ,"magic-state-distillation" -- also makes selectors ,"rus" ,"teleportation" - ,"vlup_covering" + --,"vlup_covering" -- can compile just kernels ] --- this one seems to generate a Brat Graph containing three Box nodes with different Sources, --- but the same Target, which reads from all three -nonCompilingTests = ["test/compilation/closures.brat"] - compileToOutput :: FilePath -> TestTree compileToOutput file = testCaseInfo (show file) $ compileFile [] file >>= \case - Right bs -> do + Right hs -> let outputExt = if file `elem` invalidExamples then "json.invalid" else "json" - let outFile = outputDir replaceExtension (takeFileName file) outputExt - BS.writeFile outFile bs - pure $ "Written to " ++ outFile ++ " pending validation" + in mconcat <$> (forM (M.toList hs) $ \(boxName, (bs, splices)) -> do + -- ignore splices for now + let outFile = outputDir replaceExtension (takeFileName file) ((show boxName) ++ "." ++ outputExt) + BS.writeFile outFile bs + pure $ "Written to " ++ outFile ++ " pending validation\n") Left (CompilingHoles _) -> pure "Skipped as contains holes" setupCompilationTests :: IO TestTree @@ -76,7 +76,7 @@ setupCompilationTests = do tests <- findByExtension [".brat"] prefix examples <- findByExtension [".brat"] examplesPrefix createDirectoryIfMissing False outputDir - let compileTests = expectFailForPaths nonCompilingTests compileToOutput tests + let compileTests = compileToOutput <$> tests let examplesTests = testGroup "examples" $ expectFailForPaths nonCompilingExamples compileToOutput examples pure $ testGroup "compilation" (examplesTests:compileTests) From 9b803206e80b35012ed99ee7d8a28aa8c062b5dd Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 19:27:29 +0000 Subject: [PATCH 058/149] compileKernel returns HugrGraph, dump_json->HG.to_json, tidy imports --- brat/Brat/Compile/Hugr.hs | 23 ++++++++--------------- brat/Brat/Compiler.hs | 8 ++++---- brat/Data/HugrGraph.hs | 8 +++++++- brat/test/Test/Compile/Hugr.hs | 6 +++--- 4 files changed, 22 insertions(+), 23 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 1321ee7e..4187d034 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -12,7 +12,7 @@ module Brat.Compile.Hugr (compileKernel) where import Brat.Constructors.Patterns (pattern CFalse, pattern CTrue) import Brat.Checker.Monad (track, trackM, CheckingSig(..), CaptureSets) import Brat.Checker.Helpers (binderToValue) -import Brat.Checker.Types (Store(..), VEnv) +import Brat.Checker.Types (Store(..)) import Brat.Eval (eval, evalCTy, kindType) import Brat.Graph hiding (lookupNode) import Brat.Naming hiding (root) @@ -29,15 +29,11 @@ import qualified Data.HugrGraph as H import Hasochism import Control.Monad (unless) -import Data.Aeson -import Data.Bifunctor (first, second) -import qualified Data.ByteString.Lazy as BS +import Data.Bifunctor (second) import Data.Foldable (traverse_, for_) -import Data.Functor ((<&>), ($>)) -import Data.List (sortBy) +import Data.Functor ((<&>)) import qualified Data.Map as M import Data.Maybe (catMaybes, fromJust) -import Data.Ord (comparing) import Data.Traversable (for) import Control.Monad.State import Data.List.NonEmpty (NonEmpty, nonEmpty) @@ -189,9 +185,6 @@ compileConst parent tm ty = do addEdge (Port constId 0, Port loadId 0) pure loadId -dumpJSON :: Compile BS.ByteString -dumpJSON = gets hugr <&> (encode . H.serialize) - compileClauses :: NodeId -> [TypedPort] -> NonEmpty (TestMatchData m, Name) -> Compile [TypedPort] compileClauses parent ins ((matchData, rhs) :| clauses) = do (ns, _) <- gets bratGraph @@ -577,8 +570,8 @@ undoPrimTest parent inPorts outTy (PrimLitTest tm) = do compileKernel :: (Namespace, Store, Graph) -> String -> Name - -> (BS.ByteString, [(NodeId, OutPort)]) -compileKernel (nsp, store, g@(ns, es)) desc name = (hugr, holelist) where + -> (HugrGraph, [(NodeId, OutPort)]) +compileKernel (nsp, store, g@(ns, es)) desc name = (hgr, holelist) where (src_tgt, outs) = case ns M.! name of (BratNode Id _ _) -> case [srcPort | (srcPort, _, In tgt _) <- es, tgt == name ] of -- All top-level functions are compiled into Box-es, which should look like this: @@ -588,12 +581,12 @@ compileKernel (nsp, store, g@(ns, es)) desc name = (hugr, holelist) where cty = case outs of [(_, VFun Kerny cty)] -> cty startHugr = H.new nsp desc (OpDFG $ DFG (FunctionType hInTys hOutTys bratExts) []) - (hugr, holelist) = flip evalState (makeCS (g,store) startHugr) $ do + (hgr, holelist) = flip evalState (makeCS (g,store) startHugr) $ do ctr <- makeIO desc (root startHugr) compileBox ctr src_tgt - json <- dumpJSON + hugr <- gets hugr hs <- gets holes - pure (json, hs <>> []) + pure (hugr, hs <>> []) (hInTys, hOutTys) = runLocalChecking (evalCTy S0 Kerny cty <&> (\(ss :->> ts) -> (compileRo ss, compileRo ts))) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index f0f166ff..8959f510 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -24,7 +24,7 @@ import Control.Monad (when) import Control.Monad.Except import qualified Data.ByteString.Lazy as BS import Data.Foldable (for_) -import Data.HugrGraph (NodeId) +import Data.HugrGraph (HugrGraph, NodeId, to_json) import qualified Data.Map as M import System.Exit (die) @@ -87,7 +87,7 @@ compileToGraph libDirs file = do -- Map from box name to (compiled bytes, list of splices) -- TODO: should keep Hugr as struct not ByteString -type CompilationResult = M.Map Name (BS.ByteString, [(NodeId, OutPort)]) +type CompilationResult = M.Map Name (HugrGraph, [(NodeId, OutPort)]) compileFile :: [FilePath] -> String -> IO (Either CompilingHoles CompilationResult) compileFile libDirs file = do @@ -100,8 +100,8 @@ compileFile libDirs file = do compileAndPrintFile :: [FilePath] -> String -> IO () compileAndPrintFile libDirs file = compileFile libDirs file >>= \case - Right hs -> for_ (M.toList hs) $ \(n, (bs, splices)) -> do + Right hs -> for_ (M.toList hs) $ \(n, (hugr, splices)) -> do putStrLn $ "Compiled box: " ++ show n - BS.putStr bs + BS.putStr (to_json hugr) putStrLn $ "With splices: " ++ show splices Left err -> die (show err) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index a1a4e4e9..49b1883c 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -7,13 +7,16 @@ module Data.HugrGraph(NodeId, setOp, getParent, getOp, addEdge, addOrderEdge, edgeList, splice, inlineDFG, - serialize + serialize, to_json ) where import Brat.Naming (Namespace, Name(..), fresh, split) import Bwd import Data.Hugr hiding (const) +import qualified Data.ByteString.Lazy as BS +import Data.Aeson (encode) + import Control.Monad.State (State, execState, state, get, put, modify) import Data.Foldable (for_) import Data.Functor ((<&>)) @@ -194,6 +197,9 @@ takeOutEdges src = do removeFromInList ((_, inport):_) (_,inport') | inport == inport' = error "Wrong in-edge" removeFromInList (e:es) r = e:(removeFromInList es r) +to_json :: HugrGraph -> BS.ByteString +to_json = encode . serialize + serialize :: HugrGraph -> Hugr Int serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) where diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index cae4fba1..485bae33 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -1,7 +1,7 @@ module Test.Compile.Hugr where import Control.Monad (forM) - +import Data.HugrGraph (to_json) import Brat.Compiler (compileFile, CompilingHoles(..)) import Test.Checking (expectedCheckingFails) import Test.Parsing (expectedParsingFails) @@ -64,10 +64,10 @@ compileToOutput :: FilePath -> TestTree compileToOutput file = testCaseInfo (show file) $ compileFile [] file >>= \case Right hs -> let outputExt = if file `elem` invalidExamples then "json.invalid" else "json" - in mconcat <$> (forM (M.toList hs) $ \(boxName, (bs, splices)) -> do + in mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, splices)) -> do -- ignore splices for now let outFile = outputDir replaceExtension (takeFileName file) ((show boxName) ++ "." ++ outputExt) - BS.writeFile outFile bs + BS.writeFile outFile (to_json hugr) pure $ "Written to " ++ outFile ++ " pending validation\n") Left (CompilingHoles _) -> pure "Skipped as contains holes" From 7137722059e498e72182798ed0e567aa3f8419f5 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 2 Jan 2026 21:59:14 +0000 Subject: [PATCH 059/149] Interpreter compileKernel+splice. Compiles but does it work!? TODO change GraphInfo tuple->record --- brat/Brat/Machine.hs | 53 ++++++++++++++++++++++++++++---------------- 1 file changed, 34 insertions(+), 19 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index de6ef02d..116bb44d 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -1,9 +1,11 @@ module Brat.Machine (runInterpreter) where import Brat.Checker.Monad (CaptureSets) +import Brat.Checker.Types (Store) import Brat.Compiler (compileToGraph) +import Brat.Compile.Hugr (compileKernel) import Brat.Constructors.Patterns -import Brat.Naming (Name, Namespace) +import Brat.Naming (Name, Namespace, split) import Brat.Graph (Graph, NodeType (..), Node (BratNode, KernelNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..)) import Brat.QualName (QualName, plain) import Brat.Syntax.Simple (SimpleTerm(..)) @@ -11,6 +13,7 @@ import Brat.Syntax.Port (OutPort(..)) import Brat.Syntax.Common import Brat.Syntax.Value +import qualified Data.HugrGraph as HG import Hasochism import Data.Maybe (fromMaybe, fromJust) @@ -22,14 +25,14 @@ import Util (zipSameLength) import Debug.Trace -type GraphInfo = (Graph, CaptureSets) +type GraphInfo = (Graph, Store, Namespace, CaptureSets) runInterpreter :: [FilePath] -> String -> String -> IO () runInterpreter libDirs file runFunc = do - (_, (venv, _, _, _, outerGraph, capSets)) <- compileToGraph libDirs file + (root, (venv, _, _, st, outerGraph, capSets)) <- compileToGraph libDirs file print (show outerGraph) let outPorts = [op | (NamedPort op _, _ty) <- venv M.! (plain runFunc)] - let outTask = evalPorts (outerGraph,capSets) (B0 :< BratValues M.empty) B0 outPorts + let outTask = evalPorts (outerGraph, st, root, capSets) (B0 :< BratValues M.empty) B0 outPorts -- we hope outTask is a Finished. Or a Suspend. print outTask pure () @@ -46,13 +49,14 @@ data Frame where ReturnTo :: Bwd Frame -> Frame Alternatives :: [(TestMatchData Brat, Name)] -> [Value] -> Frame PerformMatchTests :: [(Src, PrimTest (BinderType Brat))] -> [(Src, BinderType Brat)] -> Name -> Frame + DoSplices :: HG.HugrGraph -> HG.NodeId -> [(HG.NodeId, OutPort)] -> Frame deriving Show data Task where EvalPort :: OutPort -> Task Suspend :: [Frame] -> Task -> Task EvalNode :: Name -> [Value] -> Task - Use :: Value -> Task -- searches for EvalPorts + Use :: Value -> Task -- searches for EvalPorts or DoSplices Finished :: [Value] -> Task -- searches for HandleNodeOutputs, or final result TryNextMatch :: Task NoMatch :: Task @@ -71,7 +75,7 @@ evalPorts g fz valz (p:ps) = run g (fz :< EvalPorts valz ps) (EvalPort p) evalPorts g fz valz [] = run g fz (Finished (valz <>> [])) evalNodeInputs :: GraphInfo -> Bwd Frame -> Name -> Task -evalNodeInputs gi@(g,_) fz name = +evalNodeInputs gi@(g,_,_,_) fz name = -- might be good to check M.keys == [0,1,....] here let srcs = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) in evalPorts gi fz B0 srcs @@ -80,26 +84,35 @@ updateCache (fz :< BratValues env) port_vals = fz :< (BratValues $ foldr (uncurr updateCache (fz :< f) pvs = (updateCache fz pvs) :< f -- updateCache B0 pvs = B0 :< (M.fromList pvs) +evalSplices :: GraphInfo -> Bwd Frame -> HG.HugrGraph -> [(HG.NodeId, OutPort)] -> Task +evalSplices gi fz hugr [] = run gi fz (Use (KernelV hugr)) +evalSplices gi fz hugr ((nid, outport):rest) = + run gi (fz :< DoSplices hugr nid rest) (EvalPort outport) + run :: GraphInfo -> Bwd Frame -> Task -> Task run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined -- Tasks that push new frames onto the stack to do things -run gi@(g@(nodes, wires), _) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of +run gi@(g@(nodes, wires), _, _, _) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of Just v -> run gi fz (Use v) Nothing -> evalNodeInputs gi (fz :< PortOfNode p) name -run g@((nodes, _), cs) fz t@(EvalNode n ins) = case nodes M.! n of +run gi@(g@(nodes, _), st, root, cs) fz t@(EvalNode n ins) = case nodes M.! n of nw | trace ("EVALNODE " ++ show nw) False -> undefined - (BratNode (Const st) _ _) -> run g fz (Finished [evalSimpleTerm st]) - (BratNode (ArithNode op) _ _) -> run g fz (Finished [evalArith op ins]) - (BratNode Id _ _) -> run g fz (Finished ins) - (BratNode (Eval func) _ _) -> run g (fz :< CallWith ins) (EvalPort func) + (BratNode (Const st) _ _) -> run gi fz (Finished [evalSimpleTerm st]) + (BratNode (ArithNode op) _ _) -> run gi fz (Finished [evalArith op ins]) + (BratNode Id _ _) -> run gi fz (Finished ins) + (BratNode (Eval func) _ _) -> run gi (fz :< CallWith ins) (EvalPort func) + (BratNode (Box src tgt) [] [(_, VFun Kerny _)]) -> + let (sub, newRoot) = split "box" root + (hugr, splices) = compileKernel (sub, st, g) "box" n + in evalSplices (g, st, newRoot, cs) fz hugr splices (BratNode (Box src tgt) _ _) -> let captureSet = fromMaybe M.empty (M.lookup n cs) capturedSrcs = S.fromList [src | (NamedPort src _name, _ty) <- concat (M.elems captureSet)] - in run g fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) - (BratNode (PatternMatch (c:|cs)) _ _) -> run g (fz :< Alternatives (c:cs) ins) TryNextMatch - (BratNode (Constructor c) _ _) -> run g fz (Finished [evalConstructor c ins]) - nw -> run g fz (StuckOnNode n nw) + in run gi fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) + (BratNode (PatternMatch (c:|cs)) _ _) -> run gi (fz :< Alternatives (c:cs) ins) TryNextMatch + (BratNode (Constructor c) _ _) -> run gi fz (Finished [evalConstructor c ins]) + nw -> run gi fz (StuckOnNode n nw) -- Tasks that unwind the stack looking for what to do with the result @@ -108,6 +121,10 @@ run gi (fz :< f) (Suspend fs t) = run gi fz (Suspend (f:fs) t) run _ B0 t@(Suspend _ _) = t ---- Use (single value) run gi (fz :< EvalPorts valz rem) (Use v) = evalPorts gi fz (valz :< v) rem +run gi (fz :< DoSplices hugr nid rest) (Use v) = + let (KernelV sub_hugr) = v + hugr' = HG.splice hugr nid sub_hugr + in evalSplices gi fz hugr' rest run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt @@ -227,15 +244,13 @@ data Value = | BoolV Bool | VecV [Value] | ThunkV BratThunk - | KernelV HugrKernel + | KernelV HG.HugrGraph data BratThunk = -- this might want to be [EvalEnv] or something like that BratClosure EvalEnv Name Name -- Captured environment, src node, tgt node | BratPrim String String (CTy Brat Z) -data HugrKernel deriving Show - instance Show Value where show (IntV x) = show x show (FloatV x) = show x From f181da433c1b1f8f5334a75d781c7d20a74a1020 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 10 Dec 2025 17:20:24 +0000 Subject: [PATCH 060/149] Eval unification inputs in pattern matching; add dummy value for *; fix golden tests --- brat/Brat/Checker/Helpers.hs | 5 +- brat/Brat/Graph.hs | 2 + brat/Brat/Machine.hs | 52 +++++++++++++------- brat/test/golden/graph/cons.brat.graph | 48 ++++++++++-------- brat/test/golden/graph/kernel.brat.graph | 56 ++++++++++++--------- brat/test/golden/graph/list.brat.graph | 42 +++++++++------- brat/test/golden/graph/pair.brat.graph | 32 +++++++----- brat/test/golden/graph/vec.brat.graph | 62 +++++++++++++----------- 8 files changed, 180 insertions(+), 119 deletions(-) diff --git a/brat/Brat/Checker/Helpers.hs b/brat/Brat/Checker/Helpers.hs index 38d78c63..618fc4f6 100644 --- a/brat/Brat/Checker/Helpers.hs +++ b/brat/Brat/Checker/Helpers.hs @@ -634,7 +634,10 @@ solveVal Nat it@(InEnd inn) v@(VNum nv) = do dangling <- buildNatVal nv req (Wire (end dangling, TNat, inn)) defineEnd "solveValNat" it v -solveVal _ it v = defineEnd "solveVal" it v +solveVal k@(TypeFor _ _) it@(InEnd inn) v = do + (_, _, [(dummySrc, _)], _) <- anext "" (Dummy k) (S0, Some (Zy :* S0)) R0 (REx ("dummy", k) R0) + req $ Wire (end dummySrc, kindType k, inn) + defineEnd "solveVal" it v -- Do we also need dummy wiring here? solveSem :: TypeKind -> End -> Sem -> Checking () diff --git a/brat/Brat/Graph.hs b/brat/Brat/Graph.hs index 4096cf5d..1de73e12 100644 --- a/brat/Brat/Graph.hs +++ b/brat/Brat/Graph.hs @@ -51,6 +51,8 @@ data NodeType :: Mode -> Type where ArithNode :: ArithOp -> NodeType Brat Replicate :: NodeType Brat MapFun :: NodeType a + -- The thing that gets plugged into type hopes when we solve them + Dummy :: TypeKind -> NodeType Brat deriving instance Show (NodeType a) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 116bb44d..3405bf55 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -74,11 +74,13 @@ evalPorts :: GraphInfo -> Bwd Frame -> Bwd Value -> [OutPort] -> Task evalPorts g fz valz (p:ps) = run g (fz :< EvalPorts valz ps) (EvalPort p) evalPorts g fz valz [] = run g fz (Finished (valz <>> [])) +getNodeInputs :: GraphInfo -> Name -> [OutPort] +getNodeInputs (g, _, _, _) name = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) + evalNodeInputs :: GraphInfo -> Bwd Frame -> Name -> Task -evalNodeInputs gi@(g,_,_,_) fz name = +evalNodeInputs gi fz name = -- might be good to check M.keys == [0,1,....] here - let srcs = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) - in evalPorts gi fz B0 srcs + evalPorts gi fz B0 (getNodeInputs gi name) updateCache (fz :< BratValues env) port_vals = fz :< (BratValues $ foldr (uncurry M.insert) env port_vals) updateCache (fz :< f) pvs = (updateCache fz pvs) :< f @@ -112,6 +114,7 @@ run gi@(g@(nodes, _), st, root, cs) fz t@(EvalNode n ins) = case nodes M.! n of in run gi fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) (BratNode (PatternMatch (c:|cs)) _ _) -> run gi (fz :< Alternatives (c:cs) ins) TryNextMatch (BratNode (Constructor c) _ _) -> run gi fz (Finished [evalConstructor c ins]) + (BratNode (Dummy k) _ _) -> run gi fz (Finished [DummyV]) nw -> run gi fz (StuckOnNode n nw) @@ -130,27 +133,38 @@ run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt ---- Finished (list of values) -run g (fz :< PortOfNode req@(Ex name offset)) (Finished inputs) = - run g (fz :< HandleNodeOutputs req) (EvalNode name inputs) -run g (fz :< HandleNodeOutputs req@(Ex name offset)) (Finished outputs) = - run g (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] outputs]) (Use (outputs !! offset)) -run g (B0 :< ReturnTo fz) (Finished vals) = run g fz (Finished vals) +run gi (fz :< PortOfNode req@(Ex name offset)) (Finished inputs) = + run gi (fz :< HandleNodeOutputs req) (EvalNode name inputs) +run gi (fz :< HandleNodeOutputs req@(Ex name offset)) (Finished outputs) = + run gi (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] outputs]) (Use (outputs !! offset)) +run gi (B0 :< ReturnTo fz) (Finished vals) = run gi fz (Finished vals) -- TryNextMatch -run g (fz :< Alternatives [] _) TryNextMatch = run g fz NoMatch -run g (fz :< Alternatives ((TestMatchData _ ms, box):cs) ins) TryNextMatch = +run gi (fz :< Alternatives [] _) TryNextMatch = run gi fz NoMatch +run gi (fz :< Alternatives ((TestMatchData _ ms, box):cs) ins) TryNextMatch = let MatchSequence matchInputs matchTests matchOutputs = ms testInputs = M.fromList (fromJust $ zipSameLength [src | (NamedPort src _,_ty) <- matchInputs] ins) outEnv = doAllTests testInputs matchTests - in case outEnv of - Nothing -> run g (fz :< Alternatives cs ins) TryNextMatch + in case trace ("outEnv: " ++ show outEnv ++ "\nmatchOutputs: " ++ show matchOutputs) outEnv of + Nothing -> run gi (fz :< Alternatives cs ins) TryNextMatch Just env -> - let vals = [env M.! src | (NamedPort src _, _) <- matchOutputs] - in run g (fz :< CallWith vals) (EvalPort $ Ex box 0) - -run g (fz :< BratValues _) t = run g fz t -run g B0 t = t -run g fz t = run g fz (Suspend [] t) + let vals = [miniEval gi env src | (NamedPort src _, _) <- matchOutputs] + in run gi (fz :< CallWith vals) (EvalPort $ Ex box 0) + +run gi (fz :< BratValues _) t = run gi fz t +run gi B0 t = t +run gi fz t = run gi fz (Suspend [] t) + +miniEval :: GraphInfo -> EvalEnv -> OutPort -> Value +miniEval _ env x | Just v <- M.lookup x env = v +miniEval gi@((nodes, _), _, _, _) env (Ex node 0) = + let inputs = miniEval gi env <$> getNodeInputs gi node + in case nodes M.! node of + BratNode (ArithNode op) _ _ -> evalArith op inputs + BratNode (Const x) _ _ -> evalSimpleTerm x + BratNode (Constructor c) _ _ -> evalConstructor c inputs + BratNode Id _ _ | [v] <- inputs -> v + nw -> error $ "miniEval: " ++ show nw evalConstructor :: QualName -> [Value] -> Value evalConstructor CTrue [] = BoolV True @@ -245,6 +259,7 @@ data Value = | VecV [Value] | ThunkV BratThunk | KernelV HG.HugrGraph + | DummyV data BratThunk = -- this might want to be [EvalEnv] or something like that @@ -258,5 +273,6 @@ instance Show Value where show (VecV xs) = show xs show (ThunkV _) = "" show (KernelV k) = "Kernel (" ++ show k ++ ")" + show DummyV = "Dummy" type EvalEnv = M.Map OutPort Value diff --git a/brat/test/golden/graph/cons.brat.graph b/brat/test/golden/graph/cons.brat.graph index 06981276..3206ae5a 100644 --- a/brat/test/golden/graph/cons.brat.graph +++ b/brat/test/golden/graph/cons.brat.graph @@ -1,22 +1,26 @@ Nodes: +(check_defs_1_three_2_$rhs_check'Con__2,BratNode (Dummy *) [] [("dummy",[])]) (check_defs_1_three_2_$rhs_check'Con_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) (check_defs_1_three_2_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_three_2_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 2))] [("value",Vec(Int, 3))]) -(check_defs_1_three_2_$rhs_check'Con_const_3,BratNode (Const 0) [] [("value",Int)]) +(check_defs_1_three_2_$rhs_check'Con_cons_3,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 2))] [("value",Vec(Int, 3))]) +(check_defs_1_three_2_$rhs_check'Con_const_4,BratNode (Const 0) [] [("value",Int)]) (check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) (check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst,BratNode (Const 2) [] [("value",Nat)]) (check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_two_$rhs_check'Con__2,BratNode (Dummy *) [] [("dummy",[])]) (check_defs_1_two_$rhs_check'Con_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) (check_defs_1_two_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_two_$rhs_check'Con_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) -(check_defs_1_two_$rhs_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_two_$rhs_check'Con_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_two_$rhs_check'Con_check'Con_4_check'Con_4_nil_2,BratNode (Constructor nil) [] [("value",Vec(Int, 0))]) -(check_defs_1_two_$rhs_check'Con_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 0))] [("value",Vec(Int, 1))]) -(check_defs_1_two_$rhs_check'Con_check'Con_4_const_3,BratNode (Const 2) [] [("value",Int)]) -(check_defs_1_two_$rhs_check'Con_check'Con_4_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) -(check_defs_1_two_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 1))] [("value",Vec(Int, 2))]) -(check_defs_1_two_$rhs_check'Con_const_3,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_two_$rhs_check'Con_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_two_$rhs_check'Con_check'Con_5_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_two_$rhs_check'Con_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_two_$rhs_check'Con_check'Con_5_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_two_$rhs_check'Con_check'Con_5_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_two_$rhs_check'Con_check'Con_5_check'Con_5_nil_3,BratNode (Constructor nil) [] [("value",Vec(Int, 0))]) +(check_defs_1_two_$rhs_check'Con_check'Con_5_cons_3,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 0))] [("value",Vec(Int, 1))]) +(check_defs_1_two_$rhs_check'Con_check'Con_5_const_4,BratNode (Const 2) [] [("value",Int)]) +(check_defs_1_two_$rhs_check'Con_check'Con_5_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_two_$rhs_check'Con_cons_3,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 1))] [("value",Vec(Int, 2))]) +(check_defs_1_two_$rhs_check'Con_const_4,BratNode (Const 1) [] [("value",Int)]) (check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) (check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst,BratNode (Const 1) [] [("value",Nat)]) (check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) @@ -30,17 +34,21 @@ Nodes: (globals_decl_9_three,BratNode Id [("a1",Vec(Int, 3))] [("a1",Vec(Int, 3))]) Wires: -(Ex check_defs_1_three_2_$rhs_check'Con_cons_2 0,Vec(Int, 3),In globals_decl_9_three 0) -(Ex check_defs_1_three_2_$rhs_check'Con_const_3 0,Int,In check_defs_1_three_2_$rhs_check'Con_cons_2 0) +(Ex check_defs_1_three_2_$rhs_check'Con__2 0,[],In check_defs_1_three_2_$rhs_check'Con_$!_pat2val 0) +(Ex check_defs_1_three_2_$rhs_check'Con_cons_3 0,Vec(Int, 3),In globals_decl_9_three 0) +(Ex check_defs_1_three_2_$rhs_check'Con_const_4 0,Int,In check_defs_1_three_2_$rhs_check'Con_cons_3 0) (Ex check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_three_2_$rhs_check'Con_$!_numpat2val_1 0) (Ex check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0) (Ex check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 1) -(Ex check_defs_1_two_$rhs_check'Con_check'Con_4_check'Con_4_nil_2 0,Vec(Int, 0),In check_defs_1_two_$rhs_check'Con_check'Con_4_cons_2 1) -(Ex check_defs_1_two_$rhs_check'Con_check'Con_4_cons_2 0,Vec(Int, 1),In check_defs_1_two_$rhs_check'Con_cons_2 1) -(Ex check_defs_1_two_$rhs_check'Con_check'Con_4_const_3 0,Int,In check_defs_1_two_$rhs_check'Con_check'Con_4_cons_2 0) -(Ex check_defs_1_two_$rhs_check'Con_check'Con_4_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_two_$rhs_check'Con_check'Con_4_$!_numpat2val_1 0) -(Ex check_defs_1_two_$rhs_check'Con_cons_2 0,Vec(Int, 2),In globals_decl_4_two 0) -(Ex check_defs_1_two_$rhs_check'Con_const_3 0,Int,In check_defs_1_two_$rhs_check'Con_cons_2 0) +(Ex check_defs_1_two_$rhs_check'Con__2 0,[],In check_defs_1_two_$rhs_check'Con_$!_pat2val 0) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_5__2 0,[],In check_defs_1_two_$rhs_check'Con_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_5_check'Con_5__2 0,[],In check_defs_1_two_$rhs_check'Con_check'Con_5_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_5_check'Con_5_nil_3 0,Vec(Int, 0),In check_defs_1_two_$rhs_check'Con_check'Con_5_cons_3 1) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_5_cons_3 0,Vec(Int, 1),In check_defs_1_two_$rhs_check'Con_cons_3 1) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_5_const_4 0,Int,In check_defs_1_two_$rhs_check'Con_check'Con_5_cons_3 0) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_5_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_two_$rhs_check'Con_check'Con_5_$!_numpat2val_1 0) +(Ex check_defs_1_two_$rhs_check'Con_cons_3 0,Vec(Int, 2),In globals_decl_4_two 0) +(Ex check_defs_1_two_$rhs_check'Con_const_4 0,Int,In check_defs_1_two_$rhs_check'Con_cons_3 0) (Ex check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_two_$rhs_check'Con_$!_numpat2val_1 0) (Ex check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0) (Ex check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 1) @@ -50,4 +58,4 @@ Wires: (Ex globals_Vec_6 0,[],In globals___kca_three_5 0) (Ex globals_const_3 0,Nat,In globals_Vec_1 1) (Ex globals_const_8 0,Nat,In globals_Vec_6 1) -(Ex globals_decl_4_two 0,Vec(Int, 2),In check_defs_1_three_2_$rhs_check'Con_cons_2 1) +(Ex globals_decl_4_two 0,Vec(Int, 2),In check_defs_1_three_2_$rhs_check'Con_cons_3 1) diff --git a/brat/test/golden/graph/kernel.brat.graph b/brat/test/golden/graph/kernel.brat.graph index e918270f..0c180fb5 100644 --- a/brat/test/golden/graph/kernel.brat.graph +++ b/brat/test/golden/graph/kernel.brat.graph @@ -2,21 +2,25 @@ Nodes: (check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in,KernelNode Source [] [("a1",Qubit),("b1",Qubit),("c1",Qubit)]) (check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1,KernelNode Target [("a1",Vec(Qubit, 3))] []) (check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup_thunk_2,BratNode (Box check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1) [] [("thunk",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con__2,BratNode (Dummy $) [] [("dummy",[])]) (check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) (check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2,KernelNode (Constructor nil) [] [("value",Vec(Qubit, 0))]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_cons_2,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 0))] [("value",Vec(Qubit, 1))]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_cons_2,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 1))] [("value",Vec(Qubit, 2))]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst,BratNode (Const 1) [] [("value",Nat)]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) -(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_2,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 2))] [("value",Vec(Qubit, 3))]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5__2,BratNode (Dummy $) [] [("dummy",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5__2,BratNode (Dummy $) [] [("dummy",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_check'Con_5__2,BratNode (Dummy $) [] [("dummy",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_check'Con_5_nil_3,KernelNode (Constructor nil) [] [("value",Vec(Qubit, 0))]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_cons_3,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 0))] [("value",Vec(Qubit, 1))]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_cons_3,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 1))] [("value",Vec(Qubit, 2))]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_typeEqsTail_1_$!_1_buildConst,BratNode (Const 1) [] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_3,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 2))] [("value",Vec(Qubit, 3))]) (check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) (check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_buildConst,BratNode (Const 2) [] [("value",Nat)]) (check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) @@ -36,20 +40,24 @@ Nodes: (globals_decl_9_id3,BratNode Id [("a1",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })] [("a1",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) Wires: -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2 0,Vec(Qubit, 0),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_cons_2 1) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_cons_2 0,Vec(Qubit, 1),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_cons_2 1) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_$!_numpat2val_1 0) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_cons_2 0,Vec(Qubit, 2),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_2 1) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_$!_numpat2val_1 0) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 0) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 1) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_2 0,Vec(Qubit, 3),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con__2 0,[],In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_$!_pat2val 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5__2 0,[],In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5__2 0,[],In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_check'Con_5__2 0,[],In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_check'Con_5_nil_3 0,Vec(Qubit, 0),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_cons_3 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_cons_3 0,Vec(Qubit, 1),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_cons_3 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_$!_numpat2val_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_cons_3 0,Vec(Qubit, 2),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_3 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_$!_numpat2val_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_typeEqsTail_1_$!_1_Add_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_typeEqsTail_1_$!_1_Add_1 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_3 0,Vec(Qubit, 3),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2 0) (Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_$!_numpat2val_1 0) (Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_Add_1 0) (Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_Add_1 1) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 0,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_2 0) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 1,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_cons_2 0) -(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 2,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_cons_2 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 0,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_3 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 1,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_cons_3 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 2,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_5_check'Con_5_cons_3 0) (Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_lambda 0,Vec(Qubit, 3),In check_defs_1_id3_$rhs_check'Th_thunk/out_1 0) (Ex check_defs_1_id3_$rhs_check'Th_thunk/in 0,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_lambda 0) (Ex check_defs_1_id3_$rhs_check'Th_thunk/in 1,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_lambda 1) diff --git a/brat/test/golden/graph/list.brat.graph b/brat/test/golden/graph/list.brat.graph index fc6e7300..d5928b6e 100644 --- a/brat/test/golden/graph/list.brat.graph +++ b/brat/test/golden/graph/list.brat.graph @@ -1,26 +1,34 @@ Nodes: +(check_defs_1_xs_$rhs_check'Con__2,BratNode (Dummy *) [] [("dummy",[])]) (check_defs_1_xs_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2,BratNode (Constructor nil) [] [("value",List(Int))]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_const_3,BratNode (Const 3) [] [("value",Int)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_const_3,BratNode (Const 2) [] [("value",Int)]) -(check_defs_1_xs_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) -(check_defs_1_xs_$rhs_check'Con_const_3,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5_nil_3,BratNode (Constructor nil) [] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_cons_3,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_const_4,BratNode (Const 3) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_const_4,BratNode (Const 2) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_cons_3,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_const_4,BratNode (Const 1) [] [("value",Int)]) (globals_Int_2,BratNode (Constructor Int) [] [("value",[])]) (globals_List_1,BratNode (Constructor List) [("listValue",[])] [("value",[])]) (globals_decl_3_xs,BratNode Id [("a1",List(Int))] [("a1",List(Int))]) Wires: -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2 0,List(Int),In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 1) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 0,List(Int),In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 1) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 0) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0,List(Int),In check_defs_1_xs_$rhs_check'Con_cons_2 1) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0) -(Ex check_defs_1_xs_$rhs_check'Con_cons_2 0,List(Int),In globals_decl_3_xs 0) -(Ex check_defs_1_xs_$rhs_check'Con_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con__2 0,[],In check_defs_1_xs_$rhs_check'Con_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5__2 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5__2 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5__2 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5_nil_3 0,List(Int),In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_cons_3 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_cons_3 0,List(Int),In check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_const_4 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_cons_3 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 0,List(Int),In check_defs_1_xs_$rhs_check'Con_cons_3 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_const_4 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 0) +(Ex check_defs_1_xs_$rhs_check'Con_cons_3 0,List(Int),In globals_decl_3_xs 0) +(Ex check_defs_1_xs_$rhs_check'Con_const_4 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_3 0) (Ex globals_Int_2 0,[],In globals_List_1 0) (Ex globals_List_1 0,[],In globals___kca_xs 0) diff --git a/brat/test/golden/graph/pair.brat.graph b/brat/test/golden/graph/pair.brat.graph index 88e697ab..dc69464d 100644 --- a/brat/test/golden/graph/pair.brat.graph +++ b/brat/test/golden/graph/pair.brat.graph @@ -1,13 +1,17 @@ Nodes: +(check_defs_1_xs_$rhs_check'Con__2,BratNode (Dummy *) [] [("dummy",[])]) (check_defs_1_xs_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) (check_defs_1_xs_$rhs_check'Con_$!_pat2val_1,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_pat2val_1,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_3_true_1,BratNode (Constructor true) [] [("value",Bool)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_nil_1,BratNode (Constructor nil) [] [("value",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Bool),("tail",[])] [("value",[Bool])]) -(check_defs_1_xs_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",[Bool])] [("value",[Int,Bool])]) -(check_defs_1_xs_$rhs_check'Con_const_3,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_pat2val_1,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_4_true_1,BratNode (Constructor true) [] [("value",Bool)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_nil_1,BratNode (Constructor nil) [] [("value",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3,BratNode (Constructor cons) [("head",Bool),("tail",[])] [("value",[Bool])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1__1,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_xs_$rhs_check'Con_cons_3,BratNode (Constructor cons) [("head",Int),("tail",[Bool])] [("value",[Int,Bool])]) +(check_defs_1_xs_$rhs_check'Con_const_4,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_typeEqsTail_1__1,BratNode (Dummy *) [] [("dummy",[])]) (globals_Bool_4,BratNode (Constructor Bool) [] [("value",[])]) (globals_Int_2,BratNode (Constructor Int) [] [("value",[])]) (globals_cons_1,BratNode (Constructor cons) [("head",[]),("tail",[])] [("value",[])]) @@ -16,11 +20,15 @@ Nodes: (globals_nil_5,BratNode (Constructor nil) [] [("value",[])]) Wires: -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_3_true_1 0,Bool,In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_nil_1 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 1) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0,[Bool],In check_defs_1_xs_$rhs_check'Con_cons_2 1) -(Ex check_defs_1_xs_$rhs_check'Con_cons_2 0,[Int,Bool],In globals_decl_6_xs 0) -(Ex check_defs_1_xs_$rhs_check'Con_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con__2 0,[],In check_defs_1_xs_$rhs_check'Con_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5__2 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_4_true_1 0,Bool,In check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_nil_1 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 0,[Bool],In check_defs_1_xs_$rhs_check'Con_cons_3 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1__1 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_pat2val_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_cons_3 0,[Int,Bool],In globals_decl_6_xs 0) +(Ex check_defs_1_xs_$rhs_check'Con_const_4 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_3 0) +(Ex check_defs_1_xs_$rhs_check'Con_typeEqsTail_1__1 0,[],In check_defs_1_xs_$rhs_check'Con_$!_pat2val_1 0) (Ex globals_Bool_4 0,[],In globals_cons_3 0) (Ex globals_Int_2 0,[],In globals_cons_1 0) (Ex globals_cons_1 0,[],In globals___kca_xs 0) diff --git a/brat/test/golden/graph/vec.brat.graph b/brat/test/golden/graph/vec.brat.graph index 63d51b0b..07c8f981 100644 --- a/brat/test/golden/graph/vec.brat.graph +++ b/brat/test/golden/graph/vec.brat.graph @@ -1,22 +1,26 @@ Nodes: +(check_defs_1_xs_$rhs_check'Con__2,BratNode (Dummy *) [] [("dummy",[])]) (check_defs_1_xs_$rhs_check'Con_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) (check_defs_1_xs_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2,BratNode (Constructor nil) [] [("value",Vec(Int, 0))]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 0))] [("value",Vec(Int, 1))]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_const_3,BratNode (Const 2) [] [("value",Int)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 1))] [("value",Vec(Int, 2))]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_const_3,BratNode (Const 1) [] [("value",Int)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst,BratNode (Const 1) [] [("value",Nat)]) -(check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) -(check_defs_1_xs_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 2))] [("value",Vec(Int, 3))]) -(check_defs_1_xs_$rhs_check'Con_const_3,BratNode (Const 0) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5__2,BratNode (Dummy *) [] [("dummy",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5_nil_3,BratNode (Constructor nil) [] [("value",Vec(Int, 0))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_cons_3,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 0))] [("value",Vec(Int, 1))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_const_4,BratNode (Const 2) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 1))] [("value",Vec(Int, 2))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_const_4,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1_$!_1_buildConst,BratNode (Const 1) [] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_cons_3,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 2))] [("value",Vec(Int, 3))]) +(check_defs_1_xs_$rhs_check'Con_const_4,BratNode (Const 0) [] [("value",Int)]) (check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) (check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst,BratNode (Const 2) [] [("value",Nat)]) (check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) @@ -26,17 +30,21 @@ Nodes: (globals_decl_4_xs,BratNode Id [("a1",Vec(Int, 3))] [("a1",Vec(Int, 3))]) Wires: -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2 0,Vec(Int, 0),In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 1) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 0,Vec(Int, 1),In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 1) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 0) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_$!_numpat2val_1 0) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0,Vec(Int, 2),In check_defs_1_xs_$rhs_check'Con_cons_2 1) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_numpat2val_1 0) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 0) -(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 1) -(Ex check_defs_1_xs_$rhs_check'Con_cons_2 0,Vec(Int, 3),In globals_decl_4_xs 0) -(Ex check_defs_1_xs_$rhs_check'Con_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con__2 0,[],In check_defs_1_xs_$rhs_check'Con_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5__2 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5__2 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5__2 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5_$!_pat2val 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_check'Con_5_nil_3 0,Vec(Int, 0),In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_cons_3 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_cons_3 0,Vec(Int, 1),In check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_const_4 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_cons_3 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_5_check'Con_5_$!_numpat2val_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 0,Vec(Int, 2),In check_defs_1_xs_$rhs_check'Con_cons_3 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_const_4 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_5_cons_3 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_5_$!_numpat2val_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1_$!_1_Add_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_5_typeEqsTail_1_$!_1_Add_1 1) +(Ex check_defs_1_xs_$rhs_check'Con_cons_3 0,Vec(Int, 3),In globals_decl_4_xs 0) +(Ex check_defs_1_xs_$rhs_check'Con_const_4 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_3 0) (Ex check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_xs_$rhs_check'Con_$!_numpat2val_1 0) (Ex check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0) (Ex check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 1) From b116c84b09326a3cdcabe9f45d97b258f24036f9 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 9 Jan 2026 17:10:41 +0000 Subject: [PATCH 061/149] print json, + fixes: evalSplices Use->Finished, handle CQubit --- brat/Brat/Machine.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 3405bf55..364cd8af 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -16,6 +16,7 @@ import Brat.Syntax.Value import qualified Data.HugrGraph as HG import Hasochism +import qualified Data.ByteString.Lazy as BS import Data.Maybe (fromMaybe, fromJust) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as M @@ -34,8 +35,11 @@ runInterpreter libDirs file runFunc = do let outPorts = [op | (NamedPort op _, _ty) <- venv M.! (plain runFunc)] let outTask = evalPorts (outerGraph, st, root, capSets) (B0 :< BratValues M.empty) B0 outPorts -- we hope outTask is a Finished. Or a Suspend. - print outTask - pure () + case outTask of + Finished [(KernelV hugr)] -> do + putStrLn "Final Hugr Graph:" + BS.putStr (HG.to_json hugr) + _ -> print outTask data Frame where BratValues :: EvalEnv -> Frame @@ -87,7 +91,7 @@ updateCache (fz :< f) pvs = (updateCache fz pvs) :< f -- updateCache B0 pvs = B0 :< (M.fromList pvs) evalSplices :: GraphInfo -> Bwd Frame -> HG.HugrGraph -> [(HG.NodeId, OutPort)] -> Task -evalSplices gi fz hugr [] = run gi fz (Use (KernelV hugr)) +evalSplices gi fz hugr [] = run gi fz (Finished [KernelV hugr]) evalSplices gi fz hugr ((nid, outport):rest) = run gi (fz :< DoSplices hugr nid rest) (EvalPort outport) @@ -180,8 +184,9 @@ evalConstructor CRiffle [VecV evens, VecV odds] = VecV (riffle evens odds) where riffle [] [] = [] riffle (e:es) (o:os) = e:o:riffle es os +evalConstructor CQubit [] = DummyV evalConstructor CConcatEqOdd [VecV ls, mid, VecV rs] = VecV (ls ++ mid:rs) -evalConstructor _ _ = error "Internal error: Unhandled constructor" +evalConstructor name _ = error $ "Internal error: Unhandled constructor " ++ show name doAllTests :: EvalEnv -> [(Src, PrimTest (BinderType Brat))] -> Maybe EvalEnv doAllTests env [] = Just env From a960fbb83664f9ef56572bc3794bf4ed3a20e1bb Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 9 Jan 2026 21:29:30 +0000 Subject: [PATCH 062/149] Compile toplevel kernels only --- brat/Brat/Compile/Hugr.hs | 4 +--- brat/Brat/Compiler.hs | 31 +++++++++++++++++++++++-------- brat/test/Test/Compile/Hugr.hs | 8 ++++---- 3 files changed, 28 insertions(+), 15 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 4187d034..11add84e 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -573,11 +573,9 @@ compileKernel :: (Namespace, Store, Graph) -> (HugrGraph, [(NodeId, OutPort)]) compileKernel (nsp, store, g@(ns, es)) desc name = (hgr, holelist) where (src_tgt, outs) = case ns M.! name of - (BratNode Id _ _) -> case [srcPort | (srcPort, _, In tgt _) <- es, tgt == name ] of -- All top-level functions are compiled into Box-es, which should look like this: - [Ex input 0] | Just (BratNode (Box src tgt) [] outs) <- M.lookup input ns -> ((src, tgt), outs) (BratNode (Box src tgt) [] outs) -> ((src, tgt), outs) - nt -> error $ "Can only compile Box nodes or Id from them, not " ++ show nt ++ " (for " ++ show name ++ ")" + nt -> error $ "Can only compile Box nodes, not " ++ show nt ++ " (for " ++ show name ++ ")" cty = case outs of [(_, VFun Kerny cty)] -> cty startHugr = H.new nsp desc (OpDFG $ DFG (FunctionType hInTys hOutTys bratExts) []) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index 8959f510..8355fb88 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -7,20 +7,21 @@ module Brat.Compiler (printAST ,CompilingHoles(..) ) where -import Brat.Checker.Types (TypedHole, Modey(Kerny)) +import Brat.Checker.Types (TypedHole, Modey(Kerny), VEnv) import Brat.Compile.Hugr import Brat.Dot (toDotString) import Brat.Elaborator import Brat.Error -import Brat.Graph(Node(BratNode), NodeType(Box)) +import Brat.Graph(Graph, Node(BratNode), NodeType(Box, Id)) import Brat.Load import Brat.Naming (Namespace, root, split, Name) -import Brat.Syntax.Port (OutPort) +import Brat.QualName (QualName) +import Brat.Syntax.Port (NamedPort(..), OutPort(..), InPort(..)) import Brat.Syntax.Value (Val(VFun)) import Control.Exception (evaluate) -import Control.Monad (when) +import Control.Monad (when, forM) import Control.Monad.Except import qualified Data.ByteString.Lazy as BS import Data.Foldable (for_) @@ -91,12 +92,26 @@ type CompilationResult = M.Map Name (HugrGraph, [(NodeId, OutPort)]) compileFile :: [FilePath] -> String -> IO (Either CompilingHoles CompilationResult) compileFile libDirs file = do - (newRoot, (_, _, holes, st, outerGraph, _)) <- compileToGraph libDirs file + (newRoot, (venv, decls, holes, st, outerGraph, _)) <- compileToGraph libDirs file case holes of - [] -> let boxes :: [Name] = [n | (n, BratNode (Box _ _) [] [(_, VFun Kerny _)]) <- (M.toList $ fst outerGraph)] - in Right <$> (evaluate -- turns 'error' into IO 'die' - $ M.fromList [(n, compileKernel (newRoot, st, outerGraph) "root" n) | n <- boxes]) + [] -> do + box_decls <- concat <$> forM decls (findBoxes venv outerGraph . fst) + Right <$> (evaluate -- turns 'error' into IO 'die' + $ M.fromList [(n, compileKernel (newRoot, st, outerGraph) "root" n) | n <- box_decls]) hs -> pure $ Left (CompilingHoles hs) + where + findBoxes :: VEnv -> Graph -> QualName -> IO [Name] + findBoxes venv (ns, es) name = case M.lookup name venv of + Nothing -> (putStrLn $ (show name) ++ ".... not found in VEnv") >> pure [] + Just vals -> concat <$> (forM vals $ \(NamedPort (Ex n _) _, _) -> -- so, this returns IO [Name] + case M.lookup n ns of + Just (BratNode Id _ _) -> + pure [src | (Ex src 0, _, In tgt _) <- es, tgt == n, isKernelBox src ns] + _ -> (putStrLn $ (show n) ++ ".... not an Id node") >> pure []) + isKernelBox :: Name -> M.Map Name Node -> Bool + isKernelBox name ns = case M.lookup name ns of + Just (BratNode (Box _ _ ) [] [(_, VFun Kerny _cty)]) -> True + _ -> False compileAndPrintFile :: [FilePath] -> String -> IO () compileAndPrintFile libDirs file = compileFile libDirs file >>= \case diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 485bae33..5a283d33 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -25,7 +25,7 @@ invalidExamples = (map ((++ ".brat") . ("examples" )) ["adder" ,"app" ,"dollar_kind" - ,"portpulling" + --,"portpulling" -- compiling just kernels is fine ,"eatsfull" -- Compiling hopes #96 ,"map" -- Compiling hopes #96 ,"infer_thunks" -- Weird: Mismatch between caller and callee signatures in map call @@ -42,10 +42,10 @@ nonCompilingExamples = expectedCheckingFails ++ expectedParsingFails ++ --,"ising" -- can compile just kernels --,"let" -- can compile just kernels --,"patterns" -- can compile just kernels - "qft" + --,"qft" -- can compile just kernels --,"infer" -- problems with undoing pattern tests -- can compile just kernels --,"infer2" -- problems with undoing pattern tests -- can compile just kernels - ,"fanout" -- Contains Selectors + "fanout" -- Contains Selectors --,"vectorise" -- Generates MapFun nodes which aren't implemented yet -- can compile just kernels --,"vector_solve" -- Generates "Pow" nodes which aren't implemented yet -- can compile just kernels --,"batcher-merge-sort" -- Generates MapFun nodes which aren't implemented yet -- can compile just kernels @@ -55,7 +55,7 @@ nonCompilingExamples = expectedCheckingFails ++ expectedParsingFails ++ ,"imports" ,"klet" ,"magic-state-distillation" -- also makes selectors - ,"rus" + --,"rus" -- can compile just kernels ,"teleportation" --,"vlup_covering" -- can compile just kernels ] From 5416be8c2662aead1e5f4fda2c8c1829f76c036c Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 10 Jan 2026 08:55:49 +0000 Subject: [PATCH 063/149] Review comment: M.alter in addToMap --- brat/Data/HugrGraph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 8f914435..a5d66078 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -83,7 +83,7 @@ addEdge (src@(Port s o), tgt@(Port t i)) = state $ \h@HugrGraph {..} -> _ -> error "addEdge to/from node not present" where addToMap :: Ord k => k -> v -> M.Map k [v] -> M.Map k [v] - addToMap k v m = M.insert k (v:(fromMaybe [] $ M.lookup k m)) m + addToMap k v m = M.alter (Just . (v:) . fromMaybe []) k m addOrderEdge :: (NodeId, NodeId) -> State HugrGraph () addOrderEdge (src, tgt) = addEdge (Port src orderEdgeOffset, Port tgt orderEdgeOffset) From 36ae9d1f66608f02161553afaf29ebe6eeb26f1e Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 10 Jan 2026 09:00:36 +0000 Subject: [PATCH 064/149] Review comment: check only single in-edges --- brat/Data/HugrGraph.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index a5d66078..5e2fbe16 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -16,7 +16,6 @@ import Data.Hugr hiding (const) import Control.Monad.State (State, execState, state) import Data.Foldable (for_) import Data.Bifunctor (first) -import Data.Maybe (fromMaybe) import qualified Data.Map as M track = const id @@ -77,13 +76,17 @@ addEdge :: (PortId NodeId, PortId NodeId) -> State HugrGraph () addEdge (src@(Port s o), tgt@(Port t i)) = state $ \h@HugrGraph {..} -> ((), ) $ case (M.lookup s nodes, M.lookup t nodes) of (Just _, Just _) -> h { - edges_out = addToMap s (o, tgt) edges_out, - edges_in = addToMap t (src, i) edges_in + edges_out = addToMap s (o, tgt) edges_out id, + edges_in = addToMap t (src, i) edges_in no_other_inedge } _ -> error "addEdge to/from node not present" where - addToMap :: Ord k => k -> v -> M.Map k [v] -> M.Map k [v] - addToMap k v m = M.alter (Just . (v:) . fromMaybe []) k m + addToMap :: Ord k => k -> v -> M.Map k [v] -> ([v] -> [v]) -> M.Map k [v] + addToMap k v m chk = M.alter (Just . (v:) . maybe [] chk) k m + no_other_inedge :: [(n, Int)] -> [(n, Int)] + no_other_inedge [] = [] + no_other_inedge ((n, j):xs) | i == j = error "multiple in-edges to same port" + | otherwise = (n, j) : no_other_inedge xs addOrderEdge :: (NodeId, NodeId) -> State HugrGraph () addOrderEdge (src, tgt) = addEdge (Port src orderEdgeOffset, Port tgt orderEdgeOffset) From a4523af440f15c9347431caaf080eed0018ec16a Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 10 Jan 2026 09:02:17 +0000 Subject: [PATCH 065/149] Review comments: state->modify, parent->defNode, foldl' --- brat/Brat/Compile/Hugr.hs | 6 +++--- brat/Data/HugrGraph.hs | 13 ++++++------- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 2bd81ec4..ed78e2b9 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -797,9 +797,9 @@ compileModule venv moduleNode = do -- to compute its value. bodies <- for decls (\(fnName, idNode) -> do (funTy, extra_call, body) <- analyseDecl idNode - ctr@Ctr {parent} <- freshNodeWithIO (show fnName ++ "_def") moduleNode - setOp parent (OpDefn $ FuncDefn (show fnName) funTy []) - registerFuncDef idNode (parent, extra_call) + ctr@Ctr {parent=defNode} <- freshNodeWithIO (show fnName ++ "_def") moduleNode + setOp defNode (OpDefn $ FuncDefn (show fnName) funTy []) + registerFuncDef idNode (defNode, extra_call) pure (body ctr) ) for_ bodies (\body -> do diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 5e2fbe16..9b4fe641 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -13,8 +13,8 @@ import Brat.Naming (Namespace, Name, fresh, split) import Bwd import Data.Hugr hiding (const) -import Control.Monad.State (State, execState, state) -import Data.Foldable (for_) +import Control.Monad.State (State, execState, modify, state) +import Data.Foldable (foldl', for_) import Data.Bifunctor (first) import qualified Data.Map as M @@ -47,13 +47,13 @@ freshNode parent nam = state $ \hugr@(HugrGraph {root, parents, nameSupply}) -> }) setFirstChildren :: NodeId -> [NodeId] -> State HugrGraph () -setFirstChildren p cs = state $ \h -> let nch = M.alter (\Nothing -> Just cs) p (first_children h) - in ((), h {first_children = nch}) +setFirstChildren p cs = modify $ \h -> let nch = M.alter (\Nothing -> Just cs) p (first_children h) + in h {first_children = nch} setOp :: NodeId -> HugrOp -> State HugrGraph () -- Insist the parent exists setOp name op = state $ \h@HugrGraph {parents, nodes} -> case M.lookup name parents of - Nothing -> error "name has no parent" + Nothing -> error $ "Node " ++ show name ++ " has no parent" Just _ -> -- alter + partial match is just to fail if key already present ((), h { nodes = M.alter (\Nothing -> Just op) name nodes }) @@ -142,8 +142,7 @@ renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr first_children k = M.findWithDefault [] k fc nodeStackAndIndices :: StackAndIndices nodeStackAndIndices = let just_root = (B0 :< (root, nodes M.! root), M.singleton root 0) - init = foldl addNode just_root (first_children root) - in foldl addNode init (M.keys parents) + in foldl' addNode just_root (first_children root ++ M.keys parents) addNode :: StackAndIndices -> NodeId -> StackAndIndices addNode ins n = case M.lookup n (snd ins) of From f691012317ccf868b57456bf5a336e2051e8969f Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 10 Jan 2026 09:15:46 +0000 Subject: [PATCH 066/149] comments --- brat/Data/HugrGraph.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 9b4fe641..53636730 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -46,18 +46,20 @@ freshNode parent nam = state $ \hugr@(HugrGraph {root, parents, nameSupply}) -> parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents }) +-- ERRORS if firstChildren already set for this node setFirstChildren :: NodeId -> [NodeId] -> State HugrGraph () setFirstChildren p cs = modify $ \h -> let nch = M.alter (\Nothing -> Just cs) p (first_children h) in h {first_children = nch} +-- ERRORS if op already set for this node (or node does not have parent - should not be possible) setOp :: NodeId -> HugrOp -> State HugrGraph () --- Insist the parent exists setOp name op = state $ \h@HugrGraph {parents, nodes} -> case M.lookup name parents of Nothing -> error $ "Node " ++ show name ++ " has no parent" Just _ -> -- alter + partial match is just to fail if key already present ((), h { nodes = M.alter (\Nothing -> Just op) name nodes }) +-- Create a new HugrGraph with a single node (root) with specified op new :: Namespace -> String -> HugrOp -> HugrGraph new ns nam op = let (name, ns') = fresh nam ns From d2e5473a130364aaccce3d93cec661a70b856a56 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 10 Jan 2026 09:20:50 +0000 Subject: [PATCH 067/149] WIP HugrGraph.hs separate Namespace --- brat/Data/HugrGraph.hs | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 53636730..8bbb43da 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -28,23 +28,21 @@ data HugrGraph = HugrGraph { first_children:: M.Map NodeId [NodeId], nodes :: M.Map NodeId HugrOp, edges_out :: M.Map NodeId [(Int, PortId NodeId)], - edges_in :: M.Map NodeId [(PortId NodeId, Int)], - nameSupply :: Namespace + edges_in :: M.Map NodeId [(PortId NodeId, Int)] } deriving (Eq, Show) -- we probably want a better `show` -splitNamespace :: String -> State HugrGraph Namespace -splitNamespace n = state $ \hugr -> let (nsx, nsNew) = split n (nameSupply hugr) - in (nsx, hugr {nameSupply = nsNew}) +splitNamespace :: String -> State (HugrGraph, Namespace) Namespace +splitNamespace n = state $ \(hugr, ns) -> let (nsx, nsNew) = split n ns + in (nsx, (hugr, nsNew)) -freshNode :: NodeId -> String -> State HugrGraph NodeId -freshNode parent nam = state $ \hugr@(HugrGraph {root, parents, nameSupply}) -> +freshNode :: NodeId -> String -> State (HugrGraph, Namespace) NodeId +freshNode parent nam = state $ \(hugr@HugrGraph {root, parents}, nameSupply) -> case M.lookup parent parents of Nothing | parent /= root-> error "parent does not exist" _ -> let (freshName, newSupply) = fresh nam nameSupply - in (NodeId freshName, hugr { - nameSupply = newSupply, + in (NodeId freshName, (hugr { parents = M.alter (\Nothing -> Just parent) (NodeId freshName) parents - }) + }, newSupply)) -- ERRORS if firstChildren already set for this node setFirstChildren :: NodeId -> [NodeId] -> State HugrGraph () @@ -60,19 +58,19 @@ setOp name op = state $ \h@HugrGraph {parents, nodes} -> case M.lookup name pare ((), h { nodes = M.alter (\Nothing -> Just op) name nodes }) -- Create a new HugrGraph with a single node (root) with specified op -new :: Namespace -> String -> HugrOp -> HugrGraph -new ns nam op = +new :: String -> HugrOp -> State Namespace HugrGraph +new nam op = state $ \ns -> let (name, ns') = fresh nam ns root = NodeId name - in HugrGraph { + in (HugrGraph { root, parents = M.empty, first_children = M.empty, nodes = M.singleton root op, edges_in = M.empty, - edges_out = M.empty, - nameSupply = ns' - } + edges_out = M.empty} + ,ns' + ) addEdge :: (PortId NodeId, PortId NodeId) -> State HugrGraph () addEdge (src@(Port s o), tgt@(Port t i)) = state $ \h@HugrGraph {..} -> From 10e3abd59b07e1f544bc444c5b8c7fdc92cf9d95 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 10 Jan 2026 09:55:34 +0000 Subject: [PATCH 068/149] Move Namespace out of HugrGraph into Compile monad --- brat/Brat/Compile/Hugr.hs | 27 ++++++++++++++++----------- brat/Data/HugrGraph.hs | 8 ++------ 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index ed78e2b9..c15d7e5c 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -53,6 +53,7 @@ type TypedPort = (PortId NodeId, HugrType) data CompilationState = CompilationState { bratGraph :: Graph -- the input BRAT Graph; should not be written , capSets :: CaptureSets -- environments captured by Box nodes in previous + , nameSupply :: Namespace , hugr :: HugrGraph , compiled :: M.Map Name NodeId -- Mapping from Brat nodes to Hugr nodes -- When lambda lifting, captured variables become extra function inputs. @@ -80,10 +81,11 @@ data Container = Ctr { output :: NodeId } -makeCS :: (Graph, CaptureSets, Store) -> HugrGraph -> CompilationState -makeCS (g, cs, store) hugr = +makeCS :: (Graph, Namespace, CaptureSets, Store) -> HugrGraph -> CompilationState +makeCS (g, ns, cs, store) hugr = CompilationState { bratGraph = g + , nameSupply = ns , capSets = cs , hugr = hugr , compiled = M.empty @@ -99,7 +101,11 @@ registerFuncDef name hugrDef = do put (st { decls = M.insert name hugrDef (decls st) }) freshNode :: String -> NodeId -> Compile NodeId -freshNode name parent = onHugr (H.freshNode parent name) +freshNode name parent = do + s <- get + let (r, (h', ns')) = runState (H.freshNode parent name) (hugr s, nameSupply s) + put (s {hugr=h', nameSupply=ns'}) + pure r makeIO :: String -> NodeId -> Compile Container makeIO name parent = do @@ -505,17 +511,16 @@ getOutPort parent p@(Ex srcNode srcPort) = do -- and return the latter. compileConstDfg :: NodeId -> String -> ([HugrType], [HugrType]) -> (Container -> Compile a) -> Compile (TypedPort, a) compileConstDfg parent desc (inTys, outTys) contents = do - st <- gets store - g <- gets bratGraph - cs <- gets capSets let funTy = FunctionType inTys outTys bratExts -- First, we fork off a new namespace - nsx <- onHugr (H.splitNamespace desc) + st <- get + let (nsx,ns') = split desc (nameSupply st) + put (st {nameSupply = ns'}) -- And pass that namespace into nested monad that compiles the DFG let boxdesc = "Box_" ++ desc - let h = H.new nsx boxdesc (OpDFG $ DFG funTy []) + let (h, nsx') = runState (H.new boxdesc (OpDFG $ DFG funTy [])) nsx let (a, compState) = runState (makeIO boxdesc (root h) >>= contents) - (makeCS (g,cs,st) h) + (makeCS (bratGraph st, nsx' ,capSets st, store st) h) let nestedHugr = H.serialize (hugr compState) let ht = HTFunc $ PolyFuncType [] funTy @@ -873,11 +878,11 @@ compile :: Store -> VEnv -> BS.ByteString compile store ns g capSets venv = - let hugr = H.new ns "module" (OpMod ModuleOp) + let (hugr, ns') = runState (H.new "module" (OpMod ModuleOp)) ns in evalState (trackM "compileFunctions" *> compileModule venv (root hugr) *> trackM "dumpJSON" *> dumpJSON ) - (makeCS (g, capSets, store) hugr) + (makeCS (g, ns', capSets, store) hugr) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 8bbb43da..67fedc73 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Data.HugrGraph(NodeId, HugrGraph(root), -- do NOT export contents, keep abstract - new, splitNamespace, + new, freshNode, setFirstChildren, setOp, getParent, getOp, @@ -9,7 +9,7 @@ module Data.HugrGraph(NodeId, edgeList, serialize ) where -import Brat.Naming (Namespace, Name, fresh, split) +import Brat.Naming (Namespace, Name, fresh) import Bwd import Data.Hugr hiding (const) @@ -31,10 +31,6 @@ data HugrGraph = HugrGraph { edges_in :: M.Map NodeId [(PortId NodeId, Int)] } deriving (Eq, Show) -- we probably want a better `show` -splitNamespace :: String -> State (HugrGraph, Namespace) Namespace -splitNamespace n = state $ \(hugr, ns) -> let (nsx, nsNew) = split n ns - in (nsx, (hugr, nsNew)) - freshNode :: NodeId -> String -> State (HugrGraph, Namespace) NodeId freshNode parent nam = state $ \(hugr@HugrGraph {root, parents}, nameSupply) -> case M.lookup parent parents of From 673d664a88c7ff42567ea1571f94a82f8833b571 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 10 Jan 2026 10:07:22 +0000 Subject: [PATCH 069/149] Parametrize HugrGraph by nodeid for methods that don't use Namespace --- brat/Brat/Compile/Hugr.hs | 6 ++--- brat/Data/HugrGraph.hs | 52 +++++++++++++++++++-------------------- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index c15d7e5c..f0b1f644 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -54,7 +54,7 @@ data CompilationState = CompilationState { bratGraph :: Graph -- the input BRAT Graph; should not be written , capSets :: CaptureSets -- environments captured by Box nodes in previous , nameSupply :: Namespace - , hugr :: HugrGraph + , hugr :: HugrGraph NodeId , compiled :: M.Map Name NodeId -- Mapping from Brat nodes to Hugr nodes -- When lambda lifting, captured variables become extra function inputs. -- This maps from the captured value (in the BRAT graph, perhaps outside the current func/lambda) @@ -72,7 +72,7 @@ data CompilationState = CompilationState type Compile = State CompilationState -onHugr :: State HugrGraph a -> Compile a +onHugr :: State (HugrGraph NodeId) a -> Compile a onHugr f = get >>= \s -> let (r, h') = runState f (hugr s) in put (s {hugr=h'}) >> pure r data Container = Ctr { @@ -81,7 +81,7 @@ data Container = Ctr { output :: NodeId } -makeCS :: (Graph, Namespace, CaptureSets, Store) -> HugrGraph -> CompilationState +makeCS :: (Graph, Namespace, CaptureSets, Store) -> HugrGraph NodeId -> CompilationState makeCS (g, ns, cs, store) hugr = CompilationState { bratGraph = g diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 67fedc73..d1cd5f09 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -22,16 +22,16 @@ track = const id newtype NodeId = NodeId Name deriving (Eq, Ord, Show) -data HugrGraph = HugrGraph { - root :: NodeId, - parents :: M.Map NodeId NodeId, -- definitive list of (valid) nodes, excluding root - first_children:: M.Map NodeId [NodeId], - nodes :: M.Map NodeId HugrOp, - edges_out :: M.Map NodeId [(Int, PortId NodeId)], - edges_in :: M.Map NodeId [(PortId NodeId, Int)] +data HugrGraph n = HugrGraph { + root :: n, + parents :: M.Map n n, -- definitive list of (valid) nodes, excluding root + first_children:: M.Map n [n], + nodes :: M.Map n HugrOp, + edges_out :: M.Map n [(Int, PortId n)], + edges_in :: M.Map n [(PortId n, Int)] } deriving (Eq, Show) -- we probably want a better `show` -freshNode :: NodeId -> String -> State (HugrGraph, Namespace) NodeId +freshNode :: NodeId -> String -> State (HugrGraph NodeId, Namespace) NodeId freshNode parent nam = state $ \(hugr@HugrGraph {root, parents}, nameSupply) -> case M.lookup parent parents of Nothing | parent /= root-> error "parent does not exist" @@ -41,12 +41,12 @@ freshNode parent nam = state $ \(hugr@HugrGraph {root, parents}, nameSupply) -> }, newSupply)) -- ERRORS if firstChildren already set for this node -setFirstChildren :: NodeId -> [NodeId] -> State HugrGraph () +setFirstChildren :: Ord n => n -> [n] -> State (HugrGraph n) () setFirstChildren p cs = modify $ \h -> let nch = M.alter (\Nothing -> Just cs) p (first_children h) in h {first_children = nch} -- ERRORS if op already set for this node (or node does not have parent - should not be possible) -setOp :: NodeId -> HugrOp -> State HugrGraph () +setOp :: (Ord n, Show n) => n -> HugrOp -> State (HugrGraph n) () setOp name op = state $ \h@HugrGraph {parents, nodes} -> case M.lookup name parents of Nothing -> error $ "Node " ++ show name ++ " has no parent" Just _ -> @@ -54,7 +54,7 @@ setOp name op = state $ \h@HugrGraph {parents, nodes} -> case M.lookup name pare ((), h { nodes = M.alter (\Nothing -> Just op) name nodes }) -- Create a new HugrGraph with a single node (root) with specified op -new :: String -> HugrOp -> State Namespace HugrGraph +new :: String -> HugrOp -> State Namespace (HugrGraph NodeId) new nam op = state $ \ns -> let (name, ns') = fresh nam ns root = NodeId name @@ -68,7 +68,7 @@ new nam op = state $ \ns -> ,ns' ) -addEdge :: (PortId NodeId, PortId NodeId) -> State HugrGraph () +addEdge :: Ord n =>(PortId n, PortId n) -> State (HugrGraph n) () addEdge (src@(Port s o), tgt@(Port t i)) = state $ \h@HugrGraph {..} -> ((), ) $ case (M.lookup s nodes, M.lookup t nodes) of (Just _, Just _) -> h { @@ -84,24 +84,24 @@ addEdge (src@(Port s o), tgt@(Port t i)) = state $ \h@HugrGraph {..} -> no_other_inedge ((n, j):xs) | i == j = error "multiple in-edges to same port" | otherwise = (n, j) : no_other_inedge xs -addOrderEdge :: (NodeId, NodeId) -> State HugrGraph () +addOrderEdge :: Ord n => (n, n) -> State (HugrGraph n) () addOrderEdge (src, tgt) = addEdge (Port src orderEdgeOffset, Port tgt orderEdgeOffset) -edgeList :: HugrGraph -> [(PortId NodeId, PortId NodeId)] +edgeList :: HugrGraph n -> [(PortId n, PortId n)] edgeList (HugrGraph {edges_out}) = [(Port n off, tgt) | (n, vs) <- M.assocs edges_out , (off, tgt) <- vs ] -getParent :: HugrGraph -> NodeId -> NodeId +getParent :: Ord n => HugrGraph n -> n -> n getParent HugrGraph {parents} n = parents M.! n -getOp :: HugrGraph -> NodeId -> HugrOp +getOp :: Ord n => HugrGraph n -> n -> HugrOp getOp HugrGraph {nodes} n = nodes M.! n -serialize :: HugrGraph -> Hugr Int +serialize :: forall n. (Ord n, Show n) => HugrGraph n -> Hugr Int serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) where - orderEdges :: [(NodeId, NodeId)] + orderEdges :: [(n, n)] orderEdges = -- Nonlocal edges (from a node to another which is a *descendant* of a sibling of the source) -- require an extra order edge from the source to the sibling that is ancestor of the target @@ -111,7 +111,7 @@ serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) requiresOrderEdge n2] in track ("interEdges: " ++ show interEdges) (walkUp <$> interEdges) - requiresOrderEdge :: NodeId -> Bool + requiresOrderEdge :: n -> Bool requiresOrderEdge n = case getOp hugr n of OpMod _ -> False OpDefn _ -> False @@ -121,26 +121,26 @@ serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) parentOf = getParent hugr -- Walk up the hierarchy from the tgt until we hit a node at the same level as src - walkUp :: (NodeId, NodeId) -> (NodeId, NodeId) + walkUp :: (n, n) -> (n, n) walkUp (src, tgt) | parentOf src == parentOf tgt = (src, tgt) walkUp (_, tgt) | parentOf tgt == tgt = error "Tgt was not descendant of Src-parent" walkUp (src, tgt) = walkUp (src, parentOf tgt) -- this should be local to renameAndSort but local `type` is not allowed -type StackAndIndices = (Bwd (NodeId, HugrOp) -- node is index, this is (parent, op) - , M.Map NodeId Int) +type StackAndIndices n = (Bwd (n, HugrOp) -- node is index, this is (parent, op) + , M.Map n Int) -renameAndSort :: HugrGraph -> Hugr Int +renameAndSort :: forall n . Ord n => HugrGraph n -> Hugr Int renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr ( (first transNode) <$> (fst nodeStackAndIndices) <>> [], [(Port (transNode s) o, Port (transNode t) i) | (Port s o, Port t i) <- edgeList hugr] ) where first_children k = M.findWithDefault [] k fc - nodeStackAndIndices :: StackAndIndices + nodeStackAndIndices :: StackAndIndices n nodeStackAndIndices = let just_root = (B0 :< (root, nodes M.! root), M.singleton root 0) in foldl' addNode just_root (first_children root ++ M.keys parents) - addNode :: StackAndIndices -> NodeId -> StackAndIndices + addNode :: StackAndIndices n -> n -> StackAndIndices n addNode ins n = case M.lookup n (snd ins) of (Just _) -> ins Nothing -> let @@ -152,5 +152,5 @@ renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr -- finally add first_children immediately after n in foldl addNode with_n (first_children n) - transNode :: NodeId -> Int + transNode :: n -> Int transNode = ((snd nodeStackAndIndices) M.!) From 1e34f29429d9df1bcc755e3dce26f87007d1689e Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Sat, 10 Jan 2026 10:07:53 +0000 Subject: [PATCH 070/149] hide HG.edgeList --- brat/Data/HugrGraph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index d1cd5f09..51615df3 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -6,7 +6,7 @@ module Data.HugrGraph(NodeId, setFirstChildren, setOp, getParent, getOp, addEdge, addOrderEdge, - edgeList, serialize + serialize ) where import Brat.Naming (Namespace, Name, fresh) From 00b4b16e7b990b2212c91c1d21635e3f70e3ea57 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 12 Jan 2026 19:59:40 +0000 Subject: [PATCH 071/149] comment issue 101 --- brat/test/Test/Compile/Hugr.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 2527d746..6124f4e9 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -58,8 +58,7 @@ nonCompilingExamples = expectedCheckingFails ++ expectedParsingFails ++ ,"vlup_covering" ] --- this one seems to generate a Brat Graph containing three Box nodes with different Sources, --- but the same Target, which reads from all three +-- This is https://github.com/Quantinuum/brat/issues/101 nonCompilingTests = ["test/compilation/closures.brat"] compileToOutput :: FilePath -> TestTree From 2b953b3d2a060a100bacc299238f635c6c08779c Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 16 Jan 2026 16:12:57 +0000 Subject: [PATCH 072/149] Comment what splice/inlineDFG do --- brat/Data/HugrGraph.hs | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index c0e85b33..23e7ecb8 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -101,13 +101,18 @@ getParent HugrGraph {parents} n = parents M.! n getOp :: Ord n => HugrGraph n -> n -> HugrOp getOp HugrGraph {nodes} n = nodes M.! n --- Replaces the specified node of the first Hugr, with the second Hugr, --- given a key-translation function for any non-root key of the second Hugr --- to a valid (unused) key in the first +-- Replaces the specified node of the host Hugr (in the State monad), with a new Hugr +-- (as a subtree), given a key-translation function for any non-root key of the new Hugr +-- to a valid (unused) key in the host. (The most general form of splicing.) +-- We expect the new Hugr to be DFG-rooted with the same signature as the hole +-- being replaced, although this is not enforced. splice :: forall m n. (Ord n, Ord m) => n -> HugrGraph m -> (m -> n) -> State (HugrGraph n) () splice hole add non_root_k = modify $ \host -> case (M.lookup hole (nodes host) >>= isHole) of Just (_, sig) -> case M.lookup (root add) (nodes add) of - Just (OpDFG (DFG sig' _)) | sig == sig' -> {-inlineDFG hole-} host { + -- We could inline the DFG here, which could be done more efficiently (iterating through + -- nodes of `add` but not the host), but for now we just splice in the DFG in place + -- of the hole with its subtree beneath it. + Just (OpDFG (DFG sig' _)) | sig == sig' -> host { -- prefer host entry for parent of (`hole` == root of `add`) parents = union (parents host) (M.mapKeys k $ M.map k $ parents add), -- override host `nodes` for `hole` with new (DFG) @@ -128,8 +133,9 @@ splice hole add non_root_k = modify $ \host -> case (M.lookup hole (nodes host) union = M.unionWith (\_ _ -> error "keys not disjoint") --- Replace the specified hole of a host Hugr (with NodeId keys) with a new Hugr, also --- with NodeId keys, by prefixing the new Hugr's keys with the NodeId of the hole +-- Replace the specified hole of the host Hugr (in the State monad), with a new Hugr, +-- where both have NodeId keys, by prefixing the new Hugr's keys with the NodeId of +-- the hole splice_prepend :: NodeId -> HugrGraph NodeId -> State (HugrGraph NodeId) () splice_prepend hole add = splice hole add (keyMap M.!) where @@ -141,8 +147,9 @@ splice_prepend hole add = splice hole add (keyMap M.!) -- parent is definitive list of non-root nodes keyMap = M.fromList $ [(k, prefixRoot k) | k <- M.keys (parents add)] --- Replace the specified hole of a host Hugr (with NodeId keys) with a new Hugr, of any --- key type, generating fresh NodeIds from a Namespace for the new nodes +-- Replace the specified hole of a host Hugr (in the State monad, with NodeId keys) with +-- a new Hugr of any key type, using a Namespace to generate a fresh NodeId for each node +-- of the new Hugr splice_new :: forall n. (Ord n, Show n) => NodeId -> HugrGraph n -> State (HugrGraph NodeId, Namespace) () splice_new hole add = modify $ \(host, ns) -> let @@ -152,6 +159,8 @@ splice_new hole add = modify $ \(host, ns) -> host_out = execState (splice hole add (keyMap M.!)) host in (host_out, ns_out) +-- Inline a DFG node in the Hugr, i.e. make the children of the DFG become children +-- of the DFG's parent, removing the DFG and (only) its Input+Output children inlineDFG :: Ord n => n -> State (HugrGraph n) () inlineDFG dfg = get >>= \h -> case M.lookup dfg (nodes h) of (Just (OpDFG _)) -> do From d24414194cd75a163e50df62211279f5446ac207 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Mon, 23 Feb 2026 13:05:24 +0000 Subject: [PATCH 073/149] Turn off tracing --- brat/Brat/Machine.hs | 10 +++++----- brat/test/Main.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 364cd8af..a1a335b5 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -31,13 +31,13 @@ type GraphInfo = (Graph, Store, Namespace, CaptureSets) runInterpreter :: [FilePath] -> String -> String -> IO () runInterpreter libDirs file runFunc = do (root, (venv, _, _, st, outerGraph, capSets)) <- compileToGraph libDirs file - print (show outerGraph) + --print (show outerGraph) let outPorts = [op | (NamedPort op _, _ty) <- venv M.! (plain runFunc)] let outTask = evalPorts (outerGraph, st, root, capSets) (B0 :< BratValues M.empty) B0 outPorts -- we hope outTask is a Finished. Or a Suspend. case outTask of Finished [(KernelV hugr)] -> do - putStrLn "Final Hugr Graph:" + --putStrLn "Final Hugr Graph:" BS.putStr (HG.to_json hugr) _ -> print outTask @@ -96,14 +96,14 @@ evalSplices gi fz hugr ((nid, outport):rest) = run gi (fz :< DoSplices hugr nid rest) (EvalPort outport) run :: GraphInfo -> Bwd Frame -> Task -> Task -run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined +--run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined -- Tasks that push new frames onto the stack to do things run gi@(g@(nodes, wires), _, _, _) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of Just v -> run gi fz (Use v) Nothing -> evalNodeInputs gi (fz :< PortOfNode p) name run gi@(g@(nodes, _), st, root, cs) fz t@(EvalNode n ins) = case nodes M.! n of - nw | trace ("EVALNODE " ++ show nw) False -> undefined + --nw | trace ("EVALNODE " ++ show nw) False -> undefined (BratNode (Const st) _ _) -> run gi fz (Finished [evalSimpleTerm st]) (BratNode (ArithNode op) _ _) -> run gi fz (Finished [evalArith op ins]) (BratNode Id _ _) -> run gi fz (Finished ins) @@ -149,7 +149,7 @@ run gi (fz :< Alternatives ((TestMatchData _ ms, box):cs) ins) TryNextMatch = let MatchSequence matchInputs matchTests matchOutputs = ms testInputs = M.fromList (fromJust $ zipSameLength [src | (NamedPort src _,_ty) <- matchInputs] ins) outEnv = doAllTests testInputs matchTests - in case trace ("outEnv: " ++ show outEnv ++ "\nmatchOutputs: " ++ show matchOutputs) outEnv of + in case {- trace ("outEnv: " ++ show outEnv ++ "\nmatchOutputs: " ++ show matchOutputs) -} outEnv of Nothing -> run gi (fz :< Alternatives cs ins) TryNextMatch Just env -> let vals = [miniEval gi env src | (NamedPort src _, _) <- matchOutputs] diff --git a/brat/test/Main.hs b/brat/test/Main.hs index f91033f6..21976e14 100644 --- a/brat/test/Main.hs +++ b/brat/test/Main.hs @@ -38,7 +38,7 @@ coroT1 = do Nothing -> defineEnd "test" e (VCon (PrefixName [] "nil") []) ) mkYield "coroT1" (S.singleton e) >> pure () - traceM "Yield continued" + --traceM "Yield continued" v <- req $ ELup e case v of Just _ -> pure () From ab928df212872ac457b51fbf6b3eaeaa6ad271c7 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 25 Feb 2026 12:08:20 +0000 Subject: [PATCH 074/149] Renaming frames --- brat/Brat/Machine.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index a1a335b5..73f61ff5 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -46,8 +46,11 @@ data Frame where -- Optionally "what to do when all ports evaled" - Node weight, name+offset requested -- then state of evaluating inputs: (values computed, ports whose values still needed) EvalPorts :: Bwd Value -> [OutPort] -> Frame - PortOfNode :: OutPort -> Frame - HandleNodeOutputs :: OutPort -> Frame + -- We're waiting for a task to deliver us all of the inputs for this node, + -- then we can deliver the outputs. + AwaitNodeInputs :: OutPort -> Frame + -- Also responsible for caching all node outputs + SelectFromNodeOutputs :: OutPort -> Frame -- have arguments to function, waiting for the function: CallWith :: [Value] -> Frame ReturnTo :: Bwd Frame -> Frame @@ -61,7 +64,7 @@ data Task where Suspend :: [Frame] -> Task -> Task EvalNode :: Name -> [Value] -> Task Use :: Value -> Task -- searches for EvalPorts or DoSplices - Finished :: [Value] -> Task -- searches for HandleNodeOutputs, or final result + Finished :: [Value] -> Task -- searches for SelectFromNodeOutputs, or final result TryNextMatch :: Task NoMatch :: Task StuckOnNode :: Name -> Node -> Task @@ -69,6 +72,7 @@ data Task where lookupOutport :: Bwd Frame -> OutPort -> Maybe Value lookupOutport B0 _ = Nothing +-- TODO: Highly suspect that we keep looking beyond the most local cache lookupOutport (_ :< BratValues env) p | Just v <- M.lookup p env = Just v lookupOutport (fz :< _) p = lookupOutport fz p @@ -101,7 +105,7 @@ run :: GraphInfo -> Bwd Frame -> Task -> Task -- Tasks that push new frames onto the stack to do things run gi@(g@(nodes, wires), _, _, _) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of Just v -> run gi fz (Use v) - Nothing -> evalNodeInputs gi (fz :< PortOfNode p) name + Nothing -> evalNodeInputs gi (fz :< AwaitNodeInputs p) name run gi@(g@(nodes, _), st, root, cs) fz t@(EvalNode n ins) = case nodes M.! n of --nw | trace ("EVALNODE " ++ show nw) False -> undefined (BratNode (Const st) _ _) -> run gi fz (Finished [evalSimpleTerm st]) @@ -137,9 +141,9 @@ run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt ---- Finished (list of values) -run gi (fz :< PortOfNode req@(Ex name offset)) (Finished inputs) = - run gi (fz :< HandleNodeOutputs req) (EvalNode name inputs) -run gi (fz :< HandleNodeOutputs req@(Ex name offset)) (Finished outputs) = +run gi (fz :< AwaitNodeInputs req@(Ex name offset)) (Finished inputs) = + run gi (fz :< SelectFromNodeOutputs req) (EvalNode name inputs) +run gi (fz :< SelectFromNodeOutputs req@(Ex name offset)) (Finished outputs) = run gi (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] outputs]) (Use (outputs !! offset)) run gi (B0 :< ReturnTo fz) (Finished vals) = run gi fz (Finished vals) From 3571256f9b456d12a90d4734bfc1a2d2b783d981 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 25 Feb 2026 11:42:32 +0000 Subject: [PATCH 075/149] rename union -> disjoint union, use more --- brat/Data/HugrGraph.hs | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 23e7ecb8..8c5dfe89 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -113,17 +113,13 @@ splice hole add non_root_k = modify $ \host -> case (M.lookup hole (nodes host) -- nodes of `add` but not the host), but for now we just splice in the DFG in place -- of the hole with its subtree beneath it. Just (OpDFG (DFG sig' _)) | sig == sig' -> host { - -- prefer host entry for parent of (`hole` == root of `add`) - parents = union (parents host) (M.mapKeys k $ M.map k $ parents add), - -- override host `nodes` for `hole` with new (DFG) + parents = disj_union (parents host) (M.mapKeys k $ M.map k $ parents add), + -- union prefers left --> override host `nodes` for `hole` with new (DFG) nodes = M.union (M.mapKeys k (nodes add)) (nodes host), - edges_in = union (edges_in host) $ M.fromList [(k tgt, [(Port (k srcNode) srcPort, tgtPort) - | (Port srcNode srcPort, tgtPort) <- in_edges ]) - | (tgt, in_edges ) <- M.assocs (edges_in add)], - edges_out = union (edges_out host) $ M.fromList [(k src, [(srcPort, Port (k tgtNode) tgtPort) - | (srcPort, Port tgtNode tgtPort) <- out_edges]) - | (src, out_edges) <- M.assocs (edges_out add)], - first_children = union (first_children host) (M.mapKeys k $ M.map (k <$>) $ first_children add) + edges_in = disj_union (edges_in host) new_edges_in, + edges_out = disj_union (edges_out host) new_edges_out, + first_children = disj_union (first_children host) + (M.mapKeys k $ M.map (k <$>) $ first_children add) } other -> error $ "Expected DFG with sig " ++ show sig ++ "\nBut found: " ++ show other other -> error $ "Expected a hole, found " ++ show other @@ -131,7 +127,15 @@ splice hole add non_root_k = modify $ \host -> case (M.lookup hole (nodes host) k :: m -> n k n = if n == root add then hole else non_root_k n - union = M.unionWith (\_ _ -> error "keys not disjoint") + new_edges_in = M.fromList [(k tgt, [(Port (k srcNode) srcPort, tgtPort) + | (Port srcNode srcPort, tgtPort) <- in_edges ]) + | (tgt, in_edges ) <- M.assocs (edges_in add)] + + new_edges_out = M.fromList [(k src, [(srcPort, Port (k tgtNode) tgtPort) + | (srcPort, Port tgtNode tgtPort) <- out_edges]) + | (src, out_edges) <- M.assocs (edges_out add)] + + disj_union = M.unionWith (\_ _ -> error "keys not disjoint") -- Replace the specified hole of the host Hugr (in the State monad), with a new Hugr, -- where both have NodeId keys, by prefixing the new Hugr's keys with the NodeId of From 8b21e2b2846d95dc1608f71278f12501581f7178 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 25 Feb 2026 16:06:25 +0000 Subject: [PATCH 076/149] Fix input naming bug in makeIO --- brat/Brat/Compile/Hugr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index a9deabce..1e315d4b 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -92,7 +92,7 @@ freshNode name parent = do makeIO :: String -> NodeId -> Compile Container makeIO name parent = do input <- freshNode (name ++ "_Input") parent - output <- freshNode (name ++ "_Input") parent + output <- freshNode (name ++ "_Output") parent onHugr $ H.setFirstChildren parent [input, output] pure $ Ctr {parent, input, output} From db17d098db70a9fcaaaeaea84217e2b6ffd76cf8 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 25 Feb 2026 16:07:22 +0000 Subject: [PATCH 077/149] Better `Show` instance for `Frame` --- brat/Brat/Machine.hs | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index f99da154..07b827cc 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -58,7 +58,28 @@ data Frame where Alternatives :: [(TestMatchData Brat, Name)] -> [Value] -> Frame PerformMatchTests :: [(Src, PrimTest (BinderType Brat))] -> [(Src, BinderType Brat)] -> Name -> Frame DoSplices :: HG.HugrGraph HG.NodeId -> HG.NodeId -> [(HG.NodeId, OutPort)] -> Frame - deriving Show + +divider = replicate 78 '-' + +instance Show Frame where + show f = unlines $ + ["" + ,divider + ] ++ showFrame f + +showFrame :: Frame -> [String] +showFrame (BratValues env) = ["BratValues", show env] +showFrame (EvalPorts vz ports) = ["EvalPorts", show vz, "<-- You are here -->", show ports] +showFrame (AwaitNodeInputs out) = ["AwaitNodeInputs", show out ++ "<-- You are here"] +showFrame (SelectFromNodeOutputs out) = ["SelectFromNodeOutputs", show out] +showFrame (CallWith vz) = ["CallWith", show vz] +showFrame (ReturnTo fz) = "ReturnTo" : (("> " ++) <$> showFrames fz) +showFrame (Alternatives matches vz) = ["Alternatives", show matches, show vz] +showFrame (PerformMatchTests tests srcs node) = ["PerformMatchTests", show tests, show srcs, show node] -- TODO +showFrame (DoSplices hg src hugrs) = ["DoSplices", show hg, show src, show hugrs] + +showFrames :: Bwd Frame -> [String] +showFrames = foldMap (\f -> divider : showFrame f) data Task where EvalPort :: OutPort -> Task From 36946603b7027712d28ffc6fbdd736541218edd6 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 25 Feb 2026 16:08:01 +0000 Subject: [PATCH 078/149] Fix bug in `addEdge` (`parents` contains all nodes; `nodes` doesn't!) --- brat/Data/HugrGraph.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 4abbe36b..a99ea561 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -76,12 +76,14 @@ new nam op = state $ \ns -> addEdge :: Ord n =>(PortId n, PortId n) -> State (HugrGraph n) () addEdge (src@(Port s o), tgt@(Port t i)) = state $ \h@HugrGraph {..} -> - ((), ) $ case (M.lookup s nodes, M.lookup t nodes) of + ((), ) $ case (M.lookup s parents, M.lookup t parents) of (Just _, Just _) -> h { edges_out = addToMap s (o, tgt) edges_out id, edges_in = addToMap t (src, i) edges_in no_other_inedge } - _ -> error "addEdge to/from node not present" + (Nothing, Just _) -> error $ "addEdge source not present" + (Just _, Nothing) -> error $ "addEdge Target not present" + _ -> error $ "addEdge nodes not present" where addToMap :: Ord k => k -> v -> M.Map k [v] -> ([v] -> [v]) -> M.Map k [v] addToMap k v m chk = M.alter (Just . (v:) . maybe [] chk) k m @@ -160,7 +162,7 @@ splice_prepend hole add = splice hole add (keyMap M.!) splice_new :: forall n. (Ord n, Show n) => NodeId -> HugrGraph n -> State (HugrGraph NodeId, Namespace) () splice_new hole add = modify $ \(host, ns) -> let - (ns_out, keyMap) = foldr newMapping (ns, M.empty) (M.keys (parents add)) + (ns_out, keyMap) = foldr newMapping (ns, M.empty) (M.keys (parents add)) newMapping :: n -> (Namespace, M.Map n NodeId) -> (Namespace, M.Map n NodeId) newMapping n (ns, km) = let (nn, ns') = fresh (show n) ns in (ns', M.insert n (NodeId nn) km) host_out = execState (splice hole add (keyMap M.!)) host @@ -275,7 +277,7 @@ renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr nodeStackAndIndices :: StackAndIndices n nodeStackAndIndices = let just_root = (B0 :< (root, nodes M.! root), M.singleton root 0) in foldl' addNode just_root (first_children root ++ M.keys parents) - + addNode :: StackAndIndices n -> n -> StackAndIndices n addNode ins n = case M.lookup n (snd ins) of (Just _) -> ins @@ -283,7 +285,7 @@ renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr parent = parents M.! n -- guaranteed as root is always in `ins` with_parent@(stack, indices) = addNode ins parent -- add parent first, will recurse up in case M.lookup n indices of - Just _ -> with_parent -- self added by recursive call; we must be in parent's first_children + Just _ -> with_parent -- self added by recursive call; we must be in parent's first_children Nothing -> let with_n = (stack :< (parent, nodes M.! n), M.insert n (M.size indices) indices) -- finally add first_children immediately after n in foldl addNode with_n (first_children n) From 88b2a8f51c5db165c7b2e1a945b3dd0fba21a5ad Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 25 Feb 2026 16:08:50 +0000 Subject: [PATCH 079/149] Hack CR* gates into BRAT extension (for now!) --- hugr_extension/src/defs.rs | 17 +++++++++++++++-- hugr_extension/src/ops.rs | 13 +++++++++++++ 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/hugr_extension/src/defs.rs b/hugr_extension/src/defs.rs index f1683a70..2e849eb6 100644 --- a/hugr_extension/src/defs.rs +++ b/hugr_extension/src/defs.rs @@ -4,12 +4,13 @@ use crate::{closure_type, ctor::BratCtor}; use enum_iterator::Sequence; use hugr::{ extension::{ - prelude::USIZE_T, + prelude::{QB_T, USIZE_T}, simple_op::{MakeOpDef, OpLoadError}, ExtensionId, OpDef, SignatureError, SignatureFromArgs, SignatureFunc, }, ops::NamedOp, std_extensions::arithmetic::int_types::INT_TYPES, + std_extensions::arithmetic::float_types::FLOAT64_TYPE, std_extensions::collections::list_type, types::{ type_param::TypeParam, FuncValueType, PolyFuncTypeRV, Signature, Type, @@ -42,6 +43,9 @@ pub enum BratOpDef { PrimCtorTest(BratCtor), Lluf, Replicate, + CRx, + CRy, + CRz, } impl NamedOp for BratOpDef { @@ -58,6 +62,9 @@ impl NamedOp for BratOpDef { PrimCtorTest(ctor) => format_smolstr!("PrimCtorTest::{}", ctor.name()), Lluf => "Lluf".into(), Replicate => "Replicate".into(), + CRx => "CRx".into(), + CRy => "CRy".into(), + CRz => "CRz".into(), } } } @@ -78,6 +85,9 @@ impl FromStr for BratOpDef { ["PrimCtorTest", ctor] => Ok(BratOpDef::PrimCtorTest(BratCtor::from_str(ctor)?)), ["Lluf"] => Ok(BratOpDef::Lluf), ["Replicate"] => Ok(BratOpDef::Replicate), + ["CRx"] => Ok(BratOpDef::CRx), + ["CRy"] => Ok(BratOpDef::CRy), + ["CRz"] => Ok(BratOpDef::CRz), _ => Err(ParseError::VariantNotFound), } } @@ -150,7 +160,10 @@ impl MakeOpDef for BratOpDef { vec![list_type(Type::new_var_use(0, TypeBound::Copyable))], ), ) - .into(), + .into(), + CRx => Signature::new(vec![QB_T, QB_T, FLOAT64_TYPE], vec![QB_T, QB_T]).into(), + CRy => Signature::new(vec![QB_T, QB_T, FLOAT64_TYPE], vec![QB_T, QB_T]).into(), + CRz => Signature::new(vec![QB_T, QB_T, FLOAT64_TYPE], vec![QB_T, QB_T]).into(), } } diff --git a/hugr_extension/src/ops.rs b/hugr_extension/src/ops.rs index ee1159dc..5d2dc3a8 100644 --- a/hugr_extension/src/ops.rs +++ b/hugr_extension/src/ops.rs @@ -46,6 +46,9 @@ pub enum BratOp { // The inverse operation of "full" on Nats Lluf, Replicate(TypeArg), + CRx, + CRy, + CRz, } impl NamedOp for BratOp { @@ -62,6 +65,10 @@ impl NamedOp for BratOp { PrimCtorTest { ctor, .. } => format_smolstr!("PrimCtorTest::{}", ctor.name()), Lluf => "Lluf".into(), Replicate(_) => "Replicate".into(), + + CRx => "CRx".into(), + CRy => "CRy".into(), + CRz => "CRz".into(), } } } @@ -142,6 +149,9 @@ impl MakeExtensionOp for BratOp { }), BratOpDef::Lluf => Ok(BratOp::Lluf), BratOpDef::Replicate => Ok(BratOp::Replicate(ext_op.args()[0].clone())), + BratOpDef::CRx => Ok(BratOp::CRx), + BratOpDef::CRy => Ok(BratOp::CRy), + BratOpDef::CRz => Ok(BratOp::CRz), } } @@ -181,6 +191,9 @@ impl MakeExtensionOp for BratOp { BratOp::PrimCtorTest { args, .. } => args.clone(), BratOp::Lluf => vec![], BratOp::Replicate(arg) => vec![arg.clone()], + BratOp::CRx => vec![], + BratOp::CRy => vec![], + BratOp::CRz => vec![], } } } From 0385c6512c3067b6462cb70aa59a373f74611a76 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 25 Feb 2026 16:09:23 +0000 Subject: [PATCH 080/149] Add hugr rotation helpers --- brat/Data/Hugr.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/brat/Data/Hugr.hs b/brat/Data/Hugr.hs index 6ea8b202..5f9d617e 100644 --- a/brat/Data/Hugr.hs +++ b/brat/Data/Hugr.hs @@ -66,6 +66,9 @@ sumOfRows ty = error $ show ty ++ " isn't a sum of row tuples" compileSumOfRows :: SumOfRows -> HugrType compileSumOfRows (SoR rows) = HTSum (SG (GeneralSum rows)) +hugrRotation :: HugrType +hugrRotation = HTOpaque "tket.rotation" "rotation" [] TBCopy + -- Depends on HugrValue (via TypeArg in HTOpaque) data HugrType = HTQubit @@ -231,6 +234,8 @@ hvFloat x = HVExtension ["arithmetic.float_types"] hugrFloat (CC "ConstF64" (KeyMap.singleton "value" x)) hvInt x = HVExtension ["arithmetic.int_types"] hugrInt (CC "ConstInt" (KeyMap.insert "log_width" 6 (KeyMap.singleton "value" x))) +hvRotation rad = HVExtension ["tket.rotation"] hugrRotation + (CC "ConstRotation" (KeyMap.singleton "half_turns" (rad / pi))) valFromSimple :: SimpleTerm -> HugrValue valFromSimple (Num x) = hvInt x From b490ca1d28329bb3e7025384b23794ecf0b1107b Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 25 Feb 2026 16:10:13 +0000 Subject: [PATCH 081/149] Handle Prim ops in the machine --- brat/Brat/Compile/Hugr.hs | 2 +- brat/Brat/Machine.hs | 66 +++++++++++++++++++++++++++++++++++---- 2 files changed, 61 insertions(+), 7 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 1e315d4b..25cd0e5c 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -7,7 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} -module Brat.Compile.Hugr (compileKernel) where +module Brat.Compile.Hugr (compileKernel, makeIO, makeCS, CompilationState(..), addEdge, addNode, Container(..), onHugr) where import Brat.Constructors.Patterns (pattern CFalse, pattern CTrue) import Brat.Checker.Monad (track, trackM, CheckingSig(..), CaptureSets) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 07b827cc..629ac829 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -1,22 +1,25 @@ module Brat.Machine (runInterpreter) where import Brat.Checker.Monad (CaptureSets) -import Brat.Checker.Types (Store) +import Brat.Checker.Types (Store, initStore) import Brat.Compiler (compileToGraph) -import Brat.Compile.Hugr (compileKernel) +--import Brat.Compile.Hugr (compileKernel, makeIO, makeCS, addEdge, addNode, CompilationState(hugr), Container(..)) +import Brat.Compile.Hugr import Brat.Constructors.Patterns import Brat.Naming (Name, Namespace, split) -import Brat.Graph (Graph, NodeType (..), Node (BratNode, KernelNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..)) +import qualified Brat.Naming as Naming +import Brat.Graph (Graph, NodeType (..), Node (BratNode, KernelNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..), emptyGraph) import Brat.QualName (QualName, plain) import Brat.Syntax.Simple (SimpleTerm(..)) import Brat.Syntax.Port (OutPort(..)) import Brat.Syntax.Common import Brat.Syntax.Value +import Data.Hugr import qualified Data.HugrGraph as HG import Hasochism -import Control.Monad.State (execState) +import Control.Monad.State (execState, gets, evalState) import qualified Data.ByteString.Lazy as BS import Data.Maybe (fromMaybe, fromJust) import Data.List.NonEmpty (NonEmpty(..)) @@ -116,7 +119,7 @@ updateCache (fz :< BratValues env) port_vals = fz :< (BratValues $ foldr (uncurr updateCache (fz :< f) pvs = (updateCache fz pvs) :< f -- updateCache B0 pvs = B0 :< (M.fromList pvs) -evalSplices :: GraphInfo -> Bwd Frame -> HG.HugrGraph HG.NodeId-> [(HG.NodeId, OutPort)] -> Task +evalSplices :: GraphInfo -> Bwd Frame -> HG.HugrGraph HG.NodeId -> [(HG.NodeId, OutPort)] -> Task evalSplices gi fz hugr [] = run gi fz (Finished [KernelV hugr]) evalSplices gi fz hugr ((nid, outport):rest) = run gi (fz :< DoSplices hugr nid rest) (EvalPort outport) @@ -145,9 +148,9 @@ run gi@(g@(nodes, _), st, root, cs) fz t@(EvalNode n ins) = case nodes M.! n of (BratNode (PatternMatch (c:|cs)) _ _) -> run gi (fz :< Alternatives (c:cs) ins) TryNextMatch (BratNode (Constructor c) _ _) -> run gi fz (Finished [evalConstructor c ins]) (BratNode (Dummy k) _ _) -> run gi fz (Finished [DummyV]) + (BratNode (Prim (ext, op)) [] [(_, VFun Braty cty)]) -> run gi fz (Finished [ThunkV (BratPrim ext op cty)]) nw -> run gi fz (StuckOnNode n nw) - -- Tasks that unwind the stack looking for what to do with the result ----Suspend run gi (fz :< f) (Suspend fs t) = run gi fz (Suspend (f:fs) t) @@ -161,6 +164,8 @@ run gi (fz :< DoSplices hugr nid rest) (Use v) = run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt +run gi@(g,st,ns,cs) (fz :< CallWith inputs) (Use (ThunkV (BratPrim ext op cty))) + | (hugrNS,newRoot) <- split "hugr" ns, Just outs <- runPrim hugrNS (ext,op) inputs = run (g,st,newRoot,cs) fz (Finished outs) ---- Finished (list of values) run gi (fz :< AwaitNodeInputs req@(Ex name offset)) (Finished inputs) = @@ -185,6 +190,55 @@ run gi (fz :< BratValues _) t = run gi fz t run gi B0 t = t run gi fz t = run gi fz (Suspend [] t) +runPrim :: Namespace -> (String, String) -> [Value] -> Maybe [Value] +runPrim _ ("arith","i2f") [IntV v] = Just [FloatV (fromIntegral v)] +runPrim ns ("tket", op) [FloatV th] | op `elem` ["CRx", "CRy", "CRz"] = Just [KernelV (makeParametrisedGateHugr ns op th 2)] +runPrim _ _ _ = Nothing + +makeParametrisedGateHugr :: Namespace -> {- Op name: -} String -> {- angle arg: -} Double -> Int -> HG.HugrGraph HG.NodeId +makeParametrisedGateHugr ns op th nqubits = + let (ns', newRoot) = split "" ns in + hugr $ flip execState (makeCS (emptyGraph, newRoot, initStore) (dfgHugr ns')) $ do + parent <- gets (HG.root . hugr) + Ctr {parent,input,output} <- makeIO "" parent + onHugr $ HG.setOp input (OpIn (InputNode [HTQubit, HTQubit] [])) + onHugr $ HG.setOp output (OpOut (OutputNode [HTQubit, HTQubit] [])) + -- TODO: Make this a rotation (using hvRotation) when we use the actual TKET + -- ops, we're just targeting dummy ops in the BRAT extension for the sake of + -- getting things going until hugr is updated. + constTh <- addNode "k_th" (parent, OpConst (ConstOp (hvFloat th))) + th <- addNode "th" (parent, OpLoadConstant (LoadConstantOp hugrFloat)) + gate <- addNode "gate" (parent, addMetadata [("Our","Gate")] $ OpCustom gateOp) + addEdge (Port input 0, Port gate 0) + addEdge (Port input 1, Port gate 1) + addEdge (Port constTh 0, Port th 0) + addEdge (Port th 0, Port gate 2) + addEdge (Port gate 0, Port output 0) + addEdge (Port gate 1, Port output 1) + where + dfgHugr :: Namespace -> HG.HugrGraph HG.NodeId + dfgHugr = evalState (HG.new "" (OpDFG (DFG signature []))) + + signature = FunctionType + { input = [HTQubit | _ <- [1..nqubits]] + , output = [HTQubit | _ <- [1..nqubits]] + , extensions = bratExts + } + + gateOp = CustomOp + { extension = "BRAT" -- TODO: Make this "tket.quantum" + , op_name = op + , signature_ = FunctionType + { input = [HTQubit | _ <- [1..nqubits]] + ++ [hugrFloat] -- TODO: Make this hugrRotation + , output = [HTQubit | _ <- [1..nqubits]] + , extensions = bratExts + } + , args = [] + } + + + miniEval :: GraphInfo -> EvalEnv -> OutPort -> Value miniEval _ env x | Just v <- M.lookup x env = v miniEval gi@((nodes, _), _, _, _) env (Ex node 0) = From 0fdacbcce18cae1e144943396d1c141bfb3fcd93 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 27 Feb 2026 12:54:15 +0000 Subject: [PATCH 082/149] Done TODO --- brat/Brat/Compiler.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index 076b462d..7ee4935c 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -86,8 +86,7 @@ compileToGraph libDirs file = do env <- runExceptT $ loadFilename checkRoot libDirs file (newRoot,) <$> eitherIO env --- Map from box name to (compiled bytes, list of splices) --- TODO: should keep Hugr as struct not ByteString +-- Map from box name to (compiled graph, list of splices) type CompilationResult = M.Map Name (HugrGraph NodeId, [(NodeId, OutPort)]) compileFile :: [FilePath] -> String -> IO (Either CompilingHoles CompilationResult) From 646b3cc129db3e40988a40388f30e2852f6b62c9 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 14 Apr 2026 15:47:51 +0100 Subject: [PATCH 083/149] Combine parsing tests into checking --- brat/brat.cabal | 1 - brat/test/Main.hs | 3 --- brat/test/Test/Checking.hs | 36 +++++++++++++++++++++++++++------- brat/test/Test/Compile/Hugr.hs | 3 +-- brat/test/Test/Parsing.hs | 23 ---------------------- 5 files changed, 30 insertions(+), 36 deletions(-) delete mode 100644 brat/test/Test/Parsing.hs diff --git a/brat/brat.cabal b/brat/brat.cabal index 8edeb8a6..71674f4b 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -165,7 +165,6 @@ test-suite tests Test.Graph, Test.HugrGraph, Test.Libs, - Test.Parsing, Test.Naming, Test.Search, Test.Substitution, diff --git a/brat/test/Main.hs b/brat/test/Main.hs index 01db72e4..b014fd31 100644 --- a/brat/test/Main.hs +++ b/brat/test/Main.hs @@ -10,7 +10,6 @@ import Test.Failure import Test.HugrGraph import Test.Libs import Test.Naming -import Test.Parsing import Test.Search import Test.Substitution import Test.Syntax.Let @@ -62,7 +61,6 @@ coroT2 = do main = do failureTests <- getFailureTests checkingTests <- getCheckingTests - parsingTests <- getParsingTests compilationTests <- setupCompilationTests graphTests <- getGraphTests spliceTests <- getSpliceTests @@ -76,7 +74,6 @@ main = do ,letTests ,libDirTests ,nameTests - ,parsingTests ,searchTests ,elaborationTests ,substitutionTests diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index d76fd07c..84bfbc7d 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -2,29 +2,51 @@ module Test.Checking (parseAndCheck, getCheckingTests, expectedCheckingFails) wh import Brat.Load import Brat.Naming (root) -import Test.Parsing (expectedParsingFails) -import Test.Util (expectFailForPaths) import Control.Monad.Except import System.FilePath import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver +import Test.Tasty.ExpectedFailure +import qualified Data.Map as M -expectedCheckingFails = map ("examples" ) ["nested-abstractors.brat" +data XFailStatus = XFailParse | XFailCheck + +expectedFails = M.fromList $ + (map ((, XFailCheck) . ("examples" )) ["nested-abstractors.brat" ,"karlheinz.brat" ,"karlheinz_alias.brat" ,"hea.brat" -- https://github.com/Quantinuum/brat/issues/92 ,"repeated_app.brat" ,"adder.brat" - ] + ]) ++ + [("examples" "thin.brat", XFailParse)] -parseAndCheckXF :: [FilePath] -> [TestTree] -parseAndCheckXF = expectFailForPaths (expectedParsingFails ++ expectedCheckingFails) (parseAndCheck []) +expectedCheckingFails :: [FilePath] +expectedCheckingFails = M.keys expectedFails getCheckingTests :: IO TestTree -getCheckingTests = testGroup "checking" . parseAndCheckXF <$> findByExtension [".brat"] "examples" +getCheckingTests = do + paths <- findByExtension [".brat"] "examples" + let (tests, not_found) = foldr f ([], expectedFails) paths + if M.null not_found + then pure $ testGroup "examples" tests + else error $ "Tried to XFAIL non-existent tests " ++ show (M.keys not_found) + where + f :: FilePath -> ([TestTree], M.Map FilePath XFailStatus) -> ([TestTree], M.Map FilePath XFailStatus) + f path (ts, remaining_xfs) = let newTest = mkTest path (M.lookup path remaining_xfs) + in (newTest:ts, M.delete path remaining_xfs) + + mkTest :: FilePath -> Maybe XFailStatus -> TestTree + mkTest path Nothing = parseAndCheck [] path + mkTest path (Just XFailCheck) = expectFail $ mkTest path Nothing + mkTest path (Just XFailParse) = expectFail $ testCase (show path) $ do + cts <- readFile path + case parseFile path cts of + Left err -> assertFailure (show err) + Right _ -> return () -- OK parseAndCheck :: [FilePath] -> FilePath -> TestTree parseAndCheck libDirs file = testCase (show file) $ do diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 3a2d7063..c2fcc0e8 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -4,7 +4,6 @@ import Control.Monad (forM) import Data.HugrGraph (to_json) import Brat.Compiler (compileFile, CompilingHoles(..)) import Test.Checking (expectedCheckingFails) -import Test.Parsing (expectedParsingFails) import Test.Util (expectFailForPaths) import qualified Data.Map as M @@ -36,7 +35,7 @@ invalidExamples = (map ((++ ".brat") . ("examples" )) -- examples that we expect not to compile. -- Note this does not include those with remaining holes; these are automatically skipped. -nonCompilingExamples = expectedCheckingFails ++ expectedParsingFails ++ +nonCompilingExamples = expectedCheckingFails ++ map ((++ ".brat") . ("examples" )) [--"fzbz" -- can compile just kernels --,"ising" -- can compile just kernels diff --git a/brat/test/Test/Parsing.hs b/brat/test/Test/Parsing.hs deleted file mode 100644 index efe6afc8..00000000 --- a/brat/test/Test/Parsing.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Test.Parsing (getParsingTests, expectedParsingFails) where - -import Brat.Load - -import System.FilePath -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.Silver -import Test.Util (expectFailForPaths) - -testParse :: FilePath -> TestTree -testParse file = testCase (show file) $ do - cts <- readFile file - case parseFile file cts of - Left err -> assertFailure (show err) - Right _ -> return () -- OK - -expectedParsingFails = ["examples" "thin.brat"] - -parseXF = expectFailForPaths expectedParsingFails testParse - -getParsingTests :: IO TestTree -getParsingTests = testGroup "parsing" . parseXF <$> findByExtension [".brat"] "examples" From bfef2e05eedf74bd7204295324779521eeebf952 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 14 Apr 2026 17:40:28 +0100 Subject: [PATCH 084/149] Calculate checking XFAILs from file header, but still have list for compilation --- brat/examples/adder.brat | 1 + brat/examples/hea.brat | 1 + brat/examples/karlheinz.brat | 1 + brat/examples/karlheinz_alias.brat | 1 + brat/examples/nested-abstractors.brat | 1 + brat/examples/repeated_app.brat | 1 + brat/examples/thin.brat | 1 + brat/test/Test/Checking.hs | 31 ++++++++++++--------------- 8 files changed, 21 insertions(+), 17 deletions(-) diff --git a/brat/examples/adder.brat b/brat/examples/adder.brat index fc834e4b..8a2749ef 100644 --- a/brat/examples/adder.brat +++ b/brat/examples/adder.brat @@ -1,3 +1,4 @@ +--!xfail-checking xor(Bool, Bool) -> Bool xor(false, b) = b xor(a, false) = a diff --git a/brat/examples/hea.brat b/brat/examples/hea.brat index 22d80e66..18c47f40 100644 --- a/brat/examples/hea.brat +++ b/brat/examples/hea.brat @@ -1,3 +1,4 @@ +--!xfail-checking -- Playing with representing a hardware-efficient ansatz -- Expectation: diff --git a/brat/examples/karlheinz.brat b/brat/examples/karlheinz.brat index f4a9fbf1..52aff05f 100644 --- a/brat/examples/karlheinz.brat +++ b/brat/examples/karlheinz.brat @@ -1,3 +1,4 @@ +--!xfail-checking -- This file contains type signatures for various operations laid out in the -- "Types for Composite Experiments" Confluence page diff --git a/brat/examples/karlheinz_alias.brat b/brat/examples/karlheinz_alias.brat index bb3f07dd..f9b5e6cb 100644 --- a/brat/examples/karlheinz_alias.brat +++ b/brat/examples/karlheinz_alias.brat @@ -1,3 +1,4 @@ +--!xfail-checking -- This is a subset of the karlheinz.brat test file -- Expectation: diff --git a/brat/examples/nested-abstractors.brat b/brat/examples/nested-abstractors.brat index 199de4bb..422f69b2 100644 --- a/brat/examples/nested-abstractors.brat +++ b/brat/examples/nested-abstractors.brat @@ -1,3 +1,4 @@ +--!xfail-checking -- We expect that these examples should typecheck, but the machinery for dealing -- with nested rows is severly underdeveloped. diff --git a/brat/examples/repeated_app.brat b/brat/examples/repeated_app.brat index d0ba0aca..ab519079 100644 --- a/brat/examples/repeated_app.brat +++ b/brat/examples/repeated_app.brat @@ -1,3 +1,4 @@ +--!xfail-checking id(X::*) -> { X -> X } id(_) = {x => x} diff --git a/brat/examples/thin.brat b/brat/examples/thin.brat index 94ff57b9..92c99e46 100644 --- a/brat/examples/thin.brat +++ b/brat/examples/thin.brat @@ -1,3 +1,4 @@ +--!xfail-parsing -- Experiments with selecting out of vectors with first class selections -- This feature has fallen by the wayside, so expect this to fail diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index 84bfbc7d..640c2532 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -4,12 +4,14 @@ import Brat.Load import Brat.Naming (root) import Control.Monad.Except +import Data.List (isPrefixOf) +import Data.Functor ((<&>)) +import qualified Data.Map as M import System.FilePath import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver import Test.Tasty.ExpectedFailure -import qualified Data.Map as M data XFailStatus = XFailParse | XFailCheck @@ -30,23 +32,18 @@ expectedCheckingFails = M.keys expectedFails getCheckingTests :: IO TestTree getCheckingTests = do paths <- findByExtension [".brat"] "examples" - let (tests, not_found) = foldr f ([], expectedFails) paths - if M.null not_found - then pure $ testGroup "examples" tests - else error $ "Tried to XFAIL non-existent tests " ++ show (M.keys not_found) + testGroup "examples" <$> mapM mkTest paths where - f :: FilePath -> ([TestTree], M.Map FilePath XFailStatus) -> ([TestTree], M.Map FilePath XFailStatus) - f path (ts, remaining_xfs) = let newTest = mkTest path (M.lookup path remaining_xfs) - in (newTest:ts, M.delete path remaining_xfs) - - mkTest :: FilePath -> Maybe XFailStatus -> TestTree - mkTest path Nothing = parseAndCheck [] path - mkTest path (Just XFailCheck) = expectFail $ mkTest path Nothing - mkTest path (Just XFailParse) = expectFail $ testCase (show path) $ do - cts <- readFile path - case parseFile path cts of - Left err -> assertFailure (show err) - Right _ -> return () -- OK + mkTest :: FilePath -> IO TestTree + mkTest path = readFile path <&> \cts -> + if isPrefixOf "--!xfail-parsing" cts then + expectFail $ testCase (show path) $ do + case parseFile path cts of + Left err -> assertFailure (show err) + Right _ -> return () -- OK + else if isPrefixOf "--!xfail-checking" cts then + expectFail $ parseAndCheck [] path + else parseAndCheck [] path parseAndCheck :: [FilePath] -> FilePath -> TestTree parseAndCheck libDirs file = testCase (show file) $ do From b1478f6c3cd575e68f4d6f6e415575e116bfe270 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 14 Apr 2026 17:42:22 +0100 Subject: [PATCH 085/149] Remove unused nonCompilingExamples, also invalidExamples mechanism --- brat/test/Test/Compile/Hugr.hs | 24 ++---------------------- 1 file changed, 2 insertions(+), 22 deletions(-) diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index c2fcc0e8..d46bbbbe 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -18,21 +18,6 @@ prefix = "test/compilation" examplesPrefix = "examples" outputDir = prefix "output" --- examples that we expect to compile, but then to fail validation -invalidExamples :: [FilePath] -invalidExamples = (map ((++ ".brat") . ("examples" )) - ["app" - --,"adder" -- not even checking yet - ,"dollar_kind" - --,"portpulling" -- compiling just kernels is fine - ,"eatsfull" -- Compiling hopes #96 - ,"map" -- Compiling hopes #96 - ,"infer_thunks" -- Weird: Mismatch between caller and callee signatures in map call - ,"infer_thunks2" -- Weird: Mismatch between caller and callee signatures in map call - --,"repeated_app" -- not checking yet, but will be missing coercions, https://github.com/quantinuum-dev/brat/issues/413 - ] - ) - -- examples that we expect not to compile. -- Note this does not include those with remaining holes; these are automatically skipped. nonCompilingExamples = expectedCheckingFails ++ @@ -54,16 +39,11 @@ nonCompilingExamples = expectedCheckingFails ++ ,"magic-state-distillation" -- also makes selectors ] --- This is https://github.com/Quantinuum/brat/issues/101 -nonCompilingTests = ["test/compilation/closures.brat"] - compileToOutput :: FilePath -> TestTree compileToOutput file = testCaseInfo (show file) $ compileFile [] file >>= \case - Right hs -> - let outputExt = if file `elem` invalidExamples then "json.invalid" else "json" - in mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, splices)) -> do + Right hs -> mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, splices)) -> do -- ignore splices for now - let outFile = outputDir replaceExtension (takeFileName file) ((show boxName) ++ "." ++ outputExt) + let outFile = outputDir replaceExtension (takeFileName file) ((show boxName) ++ ".json") -- lots of fun with lazy and even strict bytestrings -- returning many bytes before evaluation has completed BS.writeFile outFile $! (BS.toStrict $ to_json hugr) From 4245b0b832f2434225febf20943ca62f32a52bc1 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 14 Apr 2026 19:36:25 +0100 Subject: [PATCH 086/149] Two lists via struct, expect parsing to succeed for xfail-checking --- brat/test/Test/Checking.hs | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index 640c2532..3389de3b 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -3,6 +3,7 @@ module Test.Checking (parseAndCheck, getCheckingTests, expectedCheckingFails) wh import Brat.Load import Brat.Naming (root) +import Control.Monad (foldM) import Control.Monad.Except import Data.List (isPrefixOf) import Data.Functor ((<&>)) @@ -29,21 +30,32 @@ expectedFails = M.fromList $ expectedCheckingFails :: [FilePath] expectedCheckingFails = M.keys expectedFails +data Tests = Tests + { parseTests :: [TestTree] + , checkTests :: [TestTree] + } + getCheckingTests :: IO TestTree getCheckingTests = do paths <- findByExtension [".brat"] "examples" - testGroup "examples" <$> mapM mkTest paths + ts <- foldM addTests (Tests [] []) paths + pure $ testGroup "examples" [ + testGroup "parsing" (parseTests ts), + testGroup "checking" (checkTests ts) + ] where - mkTest :: FilePath -> IO TestTree - mkTest path = readFile path <&> \cts -> - if isPrefixOf "--!xfail-parsing" cts then - expectFail $ testCase (show path) $ do - case parseFile path cts of - Left err -> assertFailure (show err) - Right _ -> return () -- OK + addTests :: Tests -> FilePath -> IO Tests + addTests tests@Tests{..} path = readFile path <&> \cts -> + let parseTest = testCase (show path) $ do + case parseFile path cts of + Left err -> assertFailure (show err) + Right _ -> return () -- OK + checkTest = parseAndCheck [] path + in if isPrefixOf "--!xfail-parsing" cts then + tests { parseTests = (expectFail parseTest):parseTests } else if isPrefixOf "--!xfail-checking" cts then - expectFail $ parseAndCheck [] path - else parseAndCheck [] path + tests { parseTests = parseTest:parseTests, checkTests = (expectFail checkTest):checkTests } + else tests {checkTests = checkTest:checkTests } parseAndCheck :: [FilePath] -> FilePath -> TestTree parseAndCheck libDirs file = testCase (show file) $ do From a75ca1a628a8f26a80a4f4ec37030bc62427f707 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 14 Apr 2026 19:46:04 +0100 Subject: [PATCH 087/149] Integrate compile tests into checking (--!xfail-compilation) --- brat/examples/fanout.brat | 1 + brat/examples/klet.brat | 1 + brat/examples/magic-state-distillation.brat | 1 + brat/test/Test/Checking.hs | 15 +++++++++++---- brat/test/Test/Compile/Hugr.hs | 11 ++--------- 5 files changed, 16 insertions(+), 13 deletions(-) diff --git a/brat/examples/fanout.brat b/brat/examples/fanout.brat index 40bd6477..ff3afa57 100644 --- a/brat/examples/fanout.brat +++ b/brat/examples/fanout.brat @@ -1,3 +1,4 @@ +--!xfail-compilation open import lib.kernel (CX) fanout(Vec(Nat, 3)) -> Nat, Nat, Nat diff --git a/brat/examples/klet.brat b/brat/examples/klet.brat index efacae76..251817bb 100644 --- a/brat/examples/klet.brat +++ b/brat/examples/klet.brat @@ -1,3 +1,4 @@ +--!xfail-compilation import lib.kernel id :: { Qubit -o Qubit } diff --git a/brat/examples/magic-state-distillation.brat b/brat/examples/magic-state-distillation.brat index 069551c0..1029aa28 100644 --- a/brat/examples/magic-state-distillation.brat +++ b/brat/examples/magic-state-distillation.brat @@ -1,3 +1,4 @@ +--!xfail-compilation open import lib.functional open import lib.kernel open import lib.math diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index 3389de3b..22bf2198 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -1,12 +1,13 @@ module Test.Checking (parseAndCheck, getCheckingTests, expectedCheckingFails) where +import Test.Compile.Hugr (compileToOutput) import Brat.Load import Brat.Naming (root) import Control.Monad (foldM) import Control.Monad.Except -import Data.List (isPrefixOf) import Data.Functor ((<&>)) +import Data.List (isPrefixOf) import qualified Data.Map as M import System.FilePath import Test.Tasty @@ -33,15 +34,17 @@ expectedCheckingFails = M.keys expectedFails data Tests = Tests { parseTests :: [TestTree] , checkTests :: [TestTree] + , compileTests :: [TestTree] } getCheckingTests :: IO TestTree getCheckingTests = do paths <- findByExtension [".brat"] "examples" - ts <- foldM addTests (Tests [] []) paths + ts <- foldM addTests (Tests [] [] []) paths pure $ testGroup "examples" [ testGroup "parsing" (parseTests ts), - testGroup "checking" (checkTests ts) + testGroup "checking" (checkTests ts), + testGroup "compilation" (compileTests ts) ] where addTests :: Tests -> FilePath -> IO Tests @@ -51,11 +54,15 @@ getCheckingTests = do Left err -> assertFailure (show err) Right _ -> return () -- OK checkTest = parseAndCheck [] path + compileTest = compileToOutput path in if isPrefixOf "--!xfail-parsing" cts then tests { parseTests = (expectFail parseTest):parseTests } else if isPrefixOf "--!xfail-checking" cts then tests { parseTests = parseTest:parseTests, checkTests = (expectFail checkTest):checkTests } - else tests {checkTests = checkTest:checkTests } + else if isPrefixOf "--!xfail-compilation" cts then + tests { checkTests = checkTest:checkTests, compileTests = (expectFail compileTest):compileTests } + else + tests { compileTests = compileTest:compileTests } parseAndCheck :: [FilePath] -> FilePath -> TestTree parseAndCheck libDirs file = testCase (show file) $ do diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index d46bbbbe..03f691ef 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -3,8 +3,6 @@ module Test.Compile.Hugr where import Control.Monad (forM) import Data.HugrGraph (to_json) import Brat.Compiler (compileFile, CompilingHoles(..)) -import Test.Checking (expectedCheckingFails) -import Test.Util (expectFailForPaths) import qualified Data.Map as M import qualified Data.ByteString as BS @@ -20,8 +18,7 @@ outputDir = prefix "output" -- examples that we expect not to compile. -- Note this does not include those with remaining holes; these are automatically skipped. -nonCompilingExamples = expectedCheckingFails ++ - map ((++ ".brat") . ("examples" )) +nonCompilingExamples = map ((++ ".brat") . ("examples" )) [--"fzbz" -- can compile just kernels --,"ising" -- can compile just kernels --,"let" -- can compile just kernels @@ -53,9 +50,5 @@ compileToOutput file = testCaseInfo (show file) $ compileFile [] file >>= \case setupCompilationTests :: IO TestTree setupCompilationTests = do tests <- findByExtension [".brat"] prefix - examples <- findByExtension [".brat"] examplesPrefix createDirectoryIfMissing False outputDir - let compileTests = compileToOutput <$> tests - let examplesTests = testGroup "examples" $ expectFailForPaths nonCompilingExamples compileToOutput examples - - pure $ testGroup "compilation" (examplesTests:compileTests) + pure $ testGroup "compilation" $ compileToOutput <$> tests From fe91e5f7d0a3b0322631793690421343261471dd Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 14:54:37 +0100 Subject: [PATCH 088/149] Remove old separate compilation tests --- brat/test/Main.hs | 3 --- brat/test/Test/Compile/Hugr.hs | 27 +++++++++++---------------- 2 files changed, 11 insertions(+), 19 deletions(-) diff --git a/brat/test/Main.hs b/brat/test/Main.hs index b014fd31..78f81193 100644 --- a/brat/test/Main.hs +++ b/brat/test/Main.hs @@ -4,7 +4,6 @@ import Test.Tasty.Silver.Interactive (defaultMain) import Test.Abstractor import Test.Checking import Test.Graph -import Test.Compile.Hugr import Test.Elaboration import Test.Failure import Test.HugrGraph @@ -61,7 +60,6 @@ coroT2 = do main = do failureTests <- getFailureTests checkingTests <- getCheckingTests - compilationTests <- setupCompilationTests graphTests <- getGraphTests spliceTests <- getSpliceTests let coroTests = testGroup "coroutine" @@ -78,7 +76,6 @@ main = do ,elaborationTests ,substitutionTests ,abstractorTests - ,compilationTests ,typeArithTests ,coroTests ,spliceTests diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 03f691ef..d7bd8387 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -10,7 +10,6 @@ import System.Directory (createDirectoryIfMissing) import System.FilePath import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.Silver prefix = "test/compilation" examplesPrefix = "examples" @@ -37,18 +36,14 @@ nonCompilingExamples = map ((++ ".brat") . ("examples" )) ] compileToOutput :: FilePath -> TestTree -compileToOutput file = testCaseInfo (show file) $ compileFile [] file >>= \case - Right hs -> mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, splices)) -> do - -- ignore splices for now - let outFile = outputDir replaceExtension (takeFileName file) ((show boxName) ++ ".json") - -- lots of fun with lazy and even strict bytestrings - -- returning many bytes before evaluation has completed - BS.writeFile outFile $! (BS.toStrict $ to_json hugr) - pure $ "Written to " ++ outFile ++ " pending validation\n") - Left (CompilingHoles _) -> pure "Skipped as contains holes" - -setupCompilationTests :: IO TestTree -setupCompilationTests = do - tests <- findByExtension [".brat"] prefix - createDirectoryIfMissing False outputDir - pure $ testGroup "compilation" $ compileToOutput <$> tests +compileToOutput file = testCaseInfo (show file) $ do + createDirectoryIfMissing False outputDir + compileFile [] file >>= \case + Right hs -> mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, splices)) -> do + -- ignore splices for now + let outFile = outputDir replaceExtension (takeFileName file) ((show boxName) ++ ".json") + -- lots of fun with lazy and even strict bytestrings + -- returning many bytes before evaluation has completed + BS.writeFile outFile $! (BS.toStrict $ to_json hugr) + pure $ "Written to " ++ outFile ++ " pending validation\n") + Left (CompilingHoles _) -> pure "Skipped as contains holes" From c54dd8e1c6554e303bd59f4bb85d99ddebf2a0f1 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 14 Apr 2026 19:49:13 +0100 Subject: [PATCH 089/149] Remove expected lists from haskell --- brat/test/Test/Checking.hs | 20 +------------------- brat/test/Test/Compile/Hugr.hs | 20 -------------------- 2 files changed, 1 insertion(+), 39 deletions(-) diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index 22bf2198..6110235d 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -1,4 +1,4 @@ -module Test.Checking (parseAndCheck, getCheckingTests, expectedCheckingFails) where +module Test.Checking (parseAndCheck, getCheckingTests) where import Test.Compile.Hugr (compileToOutput) import Brat.Load @@ -8,29 +8,11 @@ import Control.Monad (foldM) import Control.Monad.Except import Data.Functor ((<&>)) import Data.List (isPrefixOf) -import qualified Data.Map as M -import System.FilePath import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver import Test.Tasty.ExpectedFailure -data XFailStatus = XFailParse | XFailCheck - -expectedFails = M.fromList $ - (map ((, XFailCheck) . ("examples" )) ["nested-abstractors.brat" - ,"karlheinz.brat" - ,"karlheinz_alias.brat" - ,"hea.brat" - -- https://github.com/Quantinuum/brat/issues/92 - ,"repeated_app.brat" - ,"adder.brat" - ]) ++ - [("examples" "thin.brat", XFailParse)] - -expectedCheckingFails :: [FilePath] -expectedCheckingFails = M.keys expectedFails - data Tests = Tests { parseTests :: [TestTree] , checkTests :: [TestTree] diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index d7bd8387..e79f22fb 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -15,26 +15,6 @@ prefix = "test/compilation" examplesPrefix = "examples" outputDir = prefix "output" --- examples that we expect not to compile. --- Note this does not include those with remaining holes; these are automatically skipped. -nonCompilingExamples = map ((++ ".brat") . ("examples" )) - [--"fzbz" -- can compile just kernels - --,"ising" -- can compile just kernels - --,"let" -- can compile just kernels - --,"patterns" -- can compile just kernels - --,"qft" -- can compile just kernels - --,"infer" -- problems with undoing pattern tests -- can compile just kernels - --,"infer2" -- problems with undoing pattern tests -- can compile just kernels - "fanout" -- Contains Selectors - --,"vectorise" -- Generates MapFun nodes which aren't implemented yet -- can compile just kernels - --,"vector_solve" -- Generates "Pow" nodes which aren't implemented yet -- can compile just kernels - --,"batcher-merge-sort" -- Generates MapFun nodes which aren't implemented yet -- can compile just kernels - -- Victims of #13 - --,"arith" -- can compile just kernels - ,"klet" - ,"magic-state-distillation" -- also makes selectors - ] - compileToOutput :: FilePath -> TestTree compileToOutput file = testCaseInfo (show file) $ do createDirectoryIfMissing False outputDir From ea17d12b8e7f4d9d4346298dddea1705b9b730ed Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 14:55:23 +0100 Subject: [PATCH 090/149] Separate out Checking.hs from Examples.hs --- brat/brat.cabal | 1 + brat/test/Main.hs | 6 ++--- brat/test/Test/Checking.hs | 41 +-------------------------------- brat/test/Test/Examples.hs | 46 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 51 insertions(+), 43 deletions(-) create mode 100644 brat/test/Test/Examples.hs diff --git a/brat/brat.cabal b/brat/brat.cabal index 71674f4b..abab64e6 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -161,6 +161,7 @@ test-suite tests Test.Checking, Test.Compile.Hugr, Test.Elaboration, + Test.Examples, Test.Failure, Test.Graph, Test.HugrGraph, diff --git a/brat/test/Main.hs b/brat/test/Main.hs index 78f81193..3e0fda2b 100644 --- a/brat/test/Main.hs +++ b/brat/test/Main.hs @@ -2,7 +2,7 @@ import Test.Tasty (testGroup) import Test.Tasty.Silver.Interactive (defaultMain) import Test.Abstractor -import Test.Checking +import Test.Examples import Test.Graph import Test.Elaboration import Test.Failure @@ -59,7 +59,7 @@ coroT2 = do main = do failureTests <- getFailureTests - checkingTests <- getCheckingTests + examplesTests <- getExamplesTests graphTests <- getGraphTests spliceTests <- getSpliceTests let coroTests = testGroup "coroutine" @@ -68,7 +68,7 @@ main = do ] defaultMain $ testGroup "All" [graphTests ,failureTests - ,checkingTests + ,examplesTests ,letTests ,libDirTests ,nameTests diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index 6110235d..1d7b922c 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -1,50 +1,11 @@ -module Test.Checking (parseAndCheck, getCheckingTests) where +module Test.Checking (parseAndCheck) where -import Test.Compile.Hugr (compileToOutput) import Brat.Load import Brat.Naming (root) -import Control.Monad (foldM) import Control.Monad.Except -import Data.Functor ((<&>)) -import Data.List (isPrefixOf) import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.Silver -import Test.Tasty.ExpectedFailure - -data Tests = Tests - { parseTests :: [TestTree] - , checkTests :: [TestTree] - , compileTests :: [TestTree] - } - -getCheckingTests :: IO TestTree -getCheckingTests = do - paths <- findByExtension [".brat"] "examples" - ts <- foldM addTests (Tests [] [] []) paths - pure $ testGroup "examples" [ - testGroup "parsing" (parseTests ts), - testGroup "checking" (checkTests ts), - testGroup "compilation" (compileTests ts) - ] - where - addTests :: Tests -> FilePath -> IO Tests - addTests tests@Tests{..} path = readFile path <&> \cts -> - let parseTest = testCase (show path) $ do - case parseFile path cts of - Left err -> assertFailure (show err) - Right _ -> return () -- OK - checkTest = parseAndCheck [] path - compileTest = compileToOutput path - in if isPrefixOf "--!xfail-parsing" cts then - tests { parseTests = (expectFail parseTest):parseTests } - else if isPrefixOf "--!xfail-checking" cts then - tests { parseTests = parseTest:parseTests, checkTests = (expectFail checkTest):checkTests } - else if isPrefixOf "--!xfail-compilation" cts then - tests { checkTests = checkTest:checkTests, compileTests = (expectFail compileTest):compileTests } - else - tests { compileTests = compileTest:compileTests } parseAndCheck :: [FilePath] -> FilePath -> TestTree parseAndCheck libDirs file = testCase (show file) $ do diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs new file mode 100644 index 00000000..d6e21bc0 --- /dev/null +++ b/brat/test/Test/Examples.hs @@ -0,0 +1,46 @@ +module Test.Examples (getExamplesTests) where + +import Test.Checking (parseAndCheck) +import Test.Compile.Hugr (compileToOutput) +import Brat.Load + +import Control.Monad (foldM) +import Data.Functor ((<&>)) +import Data.List (isPrefixOf) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Silver +import Test.Tasty.ExpectedFailure + +data Tests = Tests + { parseTests :: [TestTree] + , checkTests :: [TestTree] + , compileTests :: [TestTree] + } + +getExamplesTests :: IO TestTree +getExamplesTests = do + paths <- findByExtension [".brat"] "examples" + ts <- foldM addTests (Tests [] [] []) paths + pure $ testGroup "examples" [ + testGroup "parsing" (parseTests ts), + testGroup "checking" (checkTests ts), + testGroup "compilation" (compileTests ts) + ] + where + addTests :: Tests -> FilePath -> IO Tests + addTests tests@Tests{..} path = readFile path <&> \cts -> + let parseTest = testCase (show path) $ do + case parseFile path cts of + Left err -> assertFailure (show err) + Right _ -> return () -- OK + checkTest = parseAndCheck [] path + compileTest = compileToOutput path + in if isPrefixOf "--!xfail-parsing" cts then + tests { parseTests = (expectFail parseTest):parseTests } + else if isPrefixOf "--!xfail-checking" cts then + tests { parseTests = parseTest:parseTests, checkTests = (expectFail checkTest):checkTests } + else if isPrefixOf "--!xfail-compilation" cts then + tests { checkTests = checkTest:checkTests, compileTests = (expectFail compileTest):compileTests } + else + tests { compileTests = compileTest:compileTests } From ddb2af03dcf582916a274b7609ca714be0bd7623 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 15 Apr 2026 11:41:33 +0100 Subject: [PATCH 091/149] WIP Execution tests parsed out of file, reading func_name from next line. Buffering problems?? --- brat/examples/arith.brat | 40 ++++++++++++++++++++++++++++++ brat/test/Test/Examples.hs | 50 +++++++++++++++++++++++++++++++++++--- 2 files changed, 87 insertions(+), 3 deletions(-) diff --git a/brat/examples/arith.brat b/brat/examples/arith.brat index 6b877b52..70119086 100644 --- a/brat/examples/arith.brat +++ b/brat/examples/arith.brat @@ -19,3 +19,43 @@ unary_minus(x) = x + -3.0 unary_minus2(Int) -> Int unary_minus2(x) = -2-x + +--!test [7] +i :: Nat +i = 3 + 4 + +--!test [-9] +j :: Int +j = unary_minus2(7) + +f :: Float +f = 2.1 * 5.3 + +g :: Float +g = 7.2 - 3.9 + +inc(Nat) -> Nat +inc(x) = x + 1 + +foo :: Nat +foo = inc(inc(4) + inc(7)) + +dec(Nat) -> Nat +dec(0) = 0 +dec(succ(n)) = n + +goo :: Nat +goo = dec(foo) + +length(X :: *, n :: #, Vec(X, n)) -> Nat +length(_, n, _) = n + +hoo(n :: #, Vec(Nat, n + 1)) -> Nat +hoo(succ(l), ls =, m ,= rs) = length(!, !, ls) +hoo(n, _) = n + +ioo :: Nat +ioo = hoo(2, [1,2,3]) + +joo :: Vec(Nat, 3) +joo = [1,2,3] diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index d6e21bc0..af6b2faa 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -3,29 +3,48 @@ module Test.Examples (getExamplesTests) where import Test.Checking (parseAndCheck) import Test.Compile.Hugr (compileToOutput) import Brat.Load +import Brat.Machine (runInterpreter) +import Control.Exception import Control.Monad (foldM) +import Data.Char (isAlphaNum) import Data.Functor ((<&>)) import Data.List (isPrefixOf) +import qualified Data.Text as T import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver +import Test.Tasty.Silver.Advanced (goldenTest) import Test.Tasty.ExpectedFailure +import System.Exit (ExitCode(..), die) +import System.IO +import System.IO.Silently + +--import Debug.Trace data Tests = Tests { parseTests :: [TestTree] , checkTests :: [TestTree] , compileTests :: [TestTree] + , executionTests :: [TestTree] } + +execTestPrefix :: T.Text +execTestPrefix = T.pack "--!test " + +interpreterOutputPrefix :: String +interpreterOutputPrefix = "Finished " + getExamplesTests :: IO TestTree getExamplesTests = do paths <- findByExtension [".brat"] "examples" - ts <- foldM addTests (Tests [] [] []) paths + ts <- foldM addTests (Tests [] [] [] []) paths pure $ testGroup "examples" [ testGroup "parsing" (parseTests ts), testGroup "checking" (checkTests ts), - testGroup "compilation" (compileTests ts) + testGroup "compilation" (compileTests ts), + testGroup "execution" (executionTests ts) ] where addTests :: Tests -> FilePath -> IO Tests @@ -43,4 +62,29 @@ getExamplesTests = do else if isPrefixOf "--!xfail-compilation" cts then tests { checkTests = checkTest:checkTests, compileTests = (expectFail compileTest):compileTests } else - tests { compileTests = compileTest:compileTests } + let interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> + let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start + expectedOutput = interpreterOutputPrefix ++ T.unpack (T.drop (T.length execTestPrefix) testLine) ++ "\n" + -- this repeats/roughly duplicates the logic for "identifiers" in the parser + func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn) + -- this completely recompiles the file for each test, which is pretty bad + in goldenVsText func_name (T.pack expectedOutput) (runInterpreter [] path func_name) + testsWithCompile = tests {compileTests = compileTest:compileTests } + in if length interpreterTests > 0 then + testsWithCompile {executionTests = (testGroup path interpreterTests):executionTests} + else testsWithCompile + +runGetStderr :: IO () -> IO String +runGetStderr action = do + (output, ()) <- hCapture [stdout, stderr] $ + action `catch` \(ExitFailure c) -> pure () + pure output + +goldenVsText :: TestName -> T.Text -> IO () -> TestTree +goldenVsText name expected action = + goldenTest name (pure expected) (runGetStderr action <&> T.pack) (do_diff) + (\_ -> die "cannot update golden, must edit test") + where + do_diff :: T.Text -> T.Text -> IO (Maybe String) + do_diff expected actual = pure $ if expected == actual then Nothing + else Just $ "Expected: " ++ T.unpack expected ++ " Actual: " ++ T.unpack actual From abd49a1b460c4697d990cfda7681311d632a529d Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 12:49:11 +0100 Subject: [PATCH 092/149] runInterpreter returns ByteString, avoid capture/golden --- brat/Brat/Machine.hs | 11 +++++------ brat/app/Main.hs | 3 ++- brat/brat.cabal | 3 ++- brat/test/Test/Examples.hs | 31 ++++++++----------------------- 4 files changed, 17 insertions(+), 31 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 872ca949..c5a30a6d 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -21,6 +21,7 @@ import Hasochism import Control.Monad.State (execState, gets, evalState) import qualified Data.ByteString.Lazy as BS +import Data.ByteString.Lazy.UTF8 (fromString) import Data.Maybe (fromMaybe, fromJust) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as M @@ -32,7 +33,7 @@ import Debug.Trace type GraphInfo = (Graph, Store, Namespace, CaptureSets) -runInterpreter :: [FilePath] -> String -> String -> IO () +runInterpreter :: [FilePath] -> String -> String -> IO (BS.ByteString) runInterpreter libDirs file runFunc = do (root, (declEnv, _, st, outerGraph, capSets)) <- compileToGraph libDirs file let venv = M.map fst declEnv @@ -40,11 +41,9 @@ runInterpreter libDirs file runFunc = do let outPorts = [op | (NamedPort op _, _ty) <- venv M.! (plain runFunc)] let outTask = evalPorts (outerGraph, st, root, capSets) (B0 :< BratValues M.empty) B0 outPorts -- we hope outTask is a Finished. Or a Suspend. - case outTask of - Finished [(KernelV hugr)] -> do - --putStrLn "Final Hugr Graph:" - BS.putStr (HG.to_json hugr) - _ -> print outTask + pure $ case outTask of + Finished [(KernelV hugr)] -> HG.to_json hugr + _ -> fromString $ show outTask data Frame where BratValues :: EvalEnv -> Frame diff --git a/brat/app/Main.hs b/brat/app/Main.hs index 95a35ee3..497e9681 100644 --- a/brat/app/Main.hs +++ b/brat/app/Main.hs @@ -1,6 +1,7 @@ import Brat.Compiler import Brat.Machine (runInterpreter) +import qualified Data.ByteString.Lazy as BS import Control.Monad (when) import Options.Applicative @@ -44,5 +45,5 @@ main = do let libDirs = parseLibs libs when (dot /= "") $ writeDot libDirs file dot if compile then compileAndPrintFile libDirs file - else if runFunc /= "" then runInterpreter libDirs file runFunc + else if runFunc /= "" then runInterpreter libDirs file runFunc >>= BS.putStr else printDeclsHoles libDirs file diff --git a/brat/brat.cabal b/brat/brat.cabal index abab64e6..53b242fe 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -119,7 +119,8 @@ library graphviz, aeson, bytestring, - transformers + transformers, + utf8-string, executable brat import: haskell, ghc-perf, warning-flags diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index af6b2faa..d650a39f 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -2,23 +2,20 @@ module Test.Examples (getExamplesTests) where import Test.Checking (parseAndCheck) import Test.Compile.Hugr (compileToOutput) -import Brat.Load +import Brat.Load (parseFile) import Brat.Machine (runInterpreter) -import Control.Exception import Control.Monad (foldM) +import Data.ByteString.Lazy (toStrict) import Data.Char (isAlphaNum) import Data.Functor ((<&>)) import Data.List (isPrefixOf) import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8Lenient) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver -import Test.Tasty.Silver.Advanced (goldenTest) import Test.Tasty.ExpectedFailure -import System.Exit (ExitCode(..), die) -import System.IO -import System.IO.Silently --import Debug.Trace @@ -64,27 +61,15 @@ getExamplesTests = do else let interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start - expectedOutput = interpreterOutputPrefix ++ T.unpack (T.drop (T.length execTestPrefix) testLine) ++ "\n" + expectedOutput = interpreterOutputPrefix ++ T.unpack (T.drop (T.length execTestPrefix) testLine) -- this repeats/roughly duplicates the logic for "identifiers" in the parser func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn) + in testCase func_name $ do -- this completely recompiles the file for each test, which is pretty bad - in goldenVsText func_name (T.pack expectedOutput) (runInterpreter [] path func_name) + output <- runInterpreter [] path func_name + let outputText = T.strip $ decodeUtf8Lenient $ toStrict output + assertEqual ("Interpreter output for " ++ func_name) expectedOutput (T.unpack outputText) testsWithCompile = tests {compileTests = compileTest:compileTests } in if length interpreterTests > 0 then testsWithCompile {executionTests = (testGroup path interpreterTests):executionTests} else testsWithCompile - -runGetStderr :: IO () -> IO String -runGetStderr action = do - (output, ()) <- hCapture [stdout, stderr] $ - action `catch` \(ExitFailure c) -> pure () - pure output - -goldenVsText :: TestName -> T.Text -> IO () -> TestTree -goldenVsText name expected action = - goldenTest name (pure expected) (runGetStderr action <&> T.pack) (do_diff) - (\_ -> die "cannot update golden, must edit test") - where - do_diff :: T.Text -> T.Text -> IO (Maybe String) - do_diff expected actual = pure $ if expected == actual then Nothing - else Just $ "Expected: " ++ T.unpack expected ++ " Actual: " ++ T.unpack actual From 5a014a917e4c413ebdc8717b85b8cb840fb7df0c Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 12:49:21 +0100 Subject: [PATCH 093/149] more tests in examples/arith.brat (remove arith.brat) --- brat/arith.brat | 37 ------------------------------------- brat/examples/arith.brat | 5 +++++ 2 files changed, 5 insertions(+), 37 deletions(-) delete mode 100644 brat/arith.brat diff --git a/brat/arith.brat b/brat/arith.brat deleted file mode 100644 index 60eeeebc..00000000 --- a/brat/arith.brat +++ /dev/null @@ -1,37 +0,0 @@ -i :: Nat -i = 3 + 4 - -j :: Nat -j = 7 - 2 - -f :: Float -f = 2.1 * 5.3 - -g :: Float -g = 7.2 - 3.9 - -inc(Nat) -> Nat -inc(x) = x + 1 - -foo :: Nat -foo = inc(inc(4) + inc(7)) - -dec(Nat) -> Nat -dec(0) = 0 -dec(succ(n)) = n - -goo :: Nat -goo = dec(foo) - -length(X :: *, n :: #, Vec(X, n)) -> Nat -length(_, n, _) = n - -hoo(n :: #, Vec(Nat, n + 1)) -> Nat -hoo(succ(l), ls =, m ,= rs) = length(!, !, ls) -hoo(n, _) = n - -ioo :: Nat -ioo = hoo(2, [1,2,3]) - -joo :: Vec(Nat, 3) -joo = [1,2,3] diff --git a/brat/examples/arith.brat b/brat/examples/arith.brat index 70119086..b41a42dd 100644 --- a/brat/examples/arith.brat +++ b/brat/examples/arith.brat @@ -28,15 +28,18 @@ i = 3 + 4 j :: Int j = unary_minus2(7) +--!test [11.13] f :: Float f = 2.1 * 5.3 +--!test [3.3000000000000003] g :: Float g = 7.2 - 3.9 inc(Nat) -> Nat inc(x) = x + 1 +--!test [14] foo :: Nat foo = inc(inc(4) + inc(7)) @@ -54,8 +57,10 @@ hoo(n :: #, Vec(Nat, n + 1)) -> Nat hoo(succ(l), ls =, m ,= rs) = length(!, !, ls) hoo(n, _) = n +--!test [1] ioo :: Nat ioo = hoo(2, [1,2,3]) +--!test [[1,2,3]] joo :: Vec(Nat, 3) joo = [1,2,3] From 5cbf449892fb99c6a3662c3641e30d141e978cf4 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 13:32:17 +0100 Subject: [PATCH 094/149] Use Data.Aeson.Text encodeToLazyText --- brat/Brat/Machine.hs | 10 +++++----- brat/app/Main.hs | 6 ++++-- brat/brat.cabal | 3 +-- brat/test/Test/Examples.hs | 7 ++----- 4 files changed, 12 insertions(+), 14 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index c5a30a6d..0dc2d383 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -15,13 +15,13 @@ import Brat.Syntax.Port (OutPort(..)) import Brat.Syntax.Common import Brat.Syntax.Value +import Data.Aeson.Text (encodeToLazyText) import Data.Hugr import qualified Data.HugrGraph as HG import Hasochism import Control.Monad.State (execState, gets, evalState) -import qualified Data.ByteString.Lazy as BS -import Data.ByteString.Lazy.UTF8 (fromString) +import qualified Data.Text.Lazy as T import Data.Maybe (fromMaybe, fromJust) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as M @@ -33,7 +33,7 @@ import Debug.Trace type GraphInfo = (Graph, Store, Namespace, CaptureSets) -runInterpreter :: [FilePath] -> String -> String -> IO (BS.ByteString) +runInterpreter :: [FilePath] -> String -> String -> IO T.Text runInterpreter libDirs file runFunc = do (root, (declEnv, _, st, outerGraph, capSets)) <- compileToGraph libDirs file let venv = M.map fst declEnv @@ -42,8 +42,8 @@ runInterpreter libDirs file runFunc = do let outTask = evalPorts (outerGraph, st, root, capSets) (B0 :< BratValues M.empty) B0 outPorts -- we hope outTask is a Finished. Or a Suspend. pure $ case outTask of - Finished [(KernelV hugr)] -> HG.to_json hugr - _ -> fromString $ show outTask + Finished [(KernelV hugr)] -> encodeToLazyText (HG.serialize hugr) + _ -> T.pack $ show outTask data Frame where BratValues :: EvalEnv -> Frame diff --git a/brat/app/Main.hs b/brat/app/Main.hs index 497e9681..e58db877 100644 --- a/brat/app/Main.hs +++ b/brat/app/Main.hs @@ -1,10 +1,12 @@ import Brat.Compiler import Brat.Machine (runInterpreter) -import qualified Data.ByteString.Lazy as BS +import Data.Text.Lazy.IO (putStr) import Control.Monad (when) import Options.Applicative +import Prelude hiding (putStr) + data Options = Opt { ast :: Bool, dot :: String, @@ -45,5 +47,5 @@ main = do let libDirs = parseLibs libs when (dot /= "") $ writeDot libDirs file dot if compile then compileAndPrintFile libDirs file - else if runFunc /= "" then runInterpreter libDirs file runFunc >>= BS.putStr + else if runFunc /= "" then runInterpreter libDirs file runFunc >>= putStr else printDeclsHoles libDirs file diff --git a/brat/brat.cabal b/brat/brat.cabal index 53b242fe..abab64e6 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -119,8 +119,7 @@ library graphviz, aeson, bytestring, - transformers, - utf8-string, + transformers executable brat import: haskell, ghc-perf, warning-flags diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index d650a39f..2e9d6c77 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -6,12 +6,10 @@ import Brat.Load (parseFile) import Brat.Machine (runInterpreter) import Control.Monad (foldM) -import Data.ByteString.Lazy (toStrict) import Data.Char (isAlphaNum) import Data.Functor ((<&>)) import Data.List (isPrefixOf) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8Lenient) +import qualified Data.Text.Lazy as T import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver @@ -67,8 +65,7 @@ getExamplesTests = do in testCase func_name $ do -- this completely recompiles the file for each test, which is pretty bad output <- runInterpreter [] path func_name - let outputText = T.strip $ decodeUtf8Lenient $ toStrict output - assertEqual ("Interpreter output for " ++ func_name) expectedOutput (T.unpack outputText) + assertEqual ("Interpreter output for " ++ func_name) expectedOutput (T.unpack output) testsWithCompile = tests {compileTests = compileTest:compileTests } in if length interpreterTests > 0 then testsWithCompile {executionTests = (testGroup path interpreterTests):executionTests} From bba87c61a20d775aa2c547d8c9ac43509b7ce4dc Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Fri, 17 Apr 2026 14:00:58 +0100 Subject: [PATCH 095/149] Update to tasty-1.5 --- brat/stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/brat/stack.yaml b/brat/stack.yaml index e91924ad..4b390fa7 100644 --- a/brat/stack.yaml +++ b/brat/stack.yaml @@ -7,3 +7,4 @@ packages: extra-deps: - partial-order-0.2.0.0@sha256:a0d6ddc9ebcfa965a5cbcff1d06d46a79d44ea5a0335c583c2a51bcb41334487,2275 +- tasty-1.5@sha256:8da3f47fff790714f7d676692f1207aac156b41f705c55f14d1d8147a751264b,2787 From 3ea59a539386572cbff25727839cbad8deaec34d Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 14:14:36 +0100 Subject: [PATCH 096/149] combine check+exec tests into sequentialTestGroup from tasty-1.5 --- brat/test/Test/Examples.hs | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index 2e9d6c77..e142b5e0 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -19,9 +19,8 @@ import Test.Tasty.ExpectedFailure data Tests = Tests { parseTests :: [TestTree] - , checkTests :: [TestTree] + , checkExecTests :: [TestTree] , compileTests :: [TestTree] - , executionTests :: [TestTree] } @@ -34,12 +33,11 @@ interpreterOutputPrefix = "Finished " getExamplesTests :: IO TestTree getExamplesTests = do paths <- findByExtension [".brat"] "examples" - ts <- foldM addTests (Tests [] [] [] []) paths + ts <- foldM addTests (Tests [] [] []) paths pure $ testGroup "examples" [ testGroup "parsing" (parseTests ts), - testGroup "checking" (checkTests ts), - testGroup "compilation" (compileTests ts), - testGroup "execution" (executionTests ts) + testGroup "check_exec" (checkExecTests ts), + testGroup "compilation" (compileTests ts) ] where addTests :: Tests -> FilePath -> IO Tests @@ -49,15 +47,13 @@ getExamplesTests = do Left err -> assertFailure (show err) Right _ -> return () -- OK checkTest = parseAndCheck [] path - compileTest = compileToOutput path in if isPrefixOf "--!xfail-parsing" cts then tests { parseTests = (expectFail parseTest):parseTests } else if isPrefixOf "--!xfail-checking" cts then - tests { parseTests = parseTest:parseTests, checkTests = (expectFail checkTest):checkTests } - else if isPrefixOf "--!xfail-compilation" cts then - tests { checkTests = checkTest:checkTests, compileTests = (expectFail compileTest):compileTests } + tests { parseTests = parseTest:parseTests, checkExecTests = (expectFail checkTest):checkExecTests } else - let interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> + let compileTest = if isPrefixOf "--!xfail-compilation" cts then expectFail (compileToOutput path) else compileToOutput path + interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start expectedOutput = interpreterOutputPrefix ++ T.unpack (T.drop (T.length execTestPrefix) testLine) -- this repeats/roughly duplicates the logic for "identifiers" in the parser @@ -66,7 +62,7 @@ getExamplesTests = do -- this completely recompiles the file for each test, which is pretty bad output <- runInterpreter [] path func_name assertEqual ("Interpreter output for " ++ func_name) expectedOutput (T.unpack output) - testsWithCompile = tests {compileTests = compileTest:compileTests } - in if length interpreterTests > 0 then - testsWithCompile {executionTests = (testGroup path interpreterTests):executionTests} - else testsWithCompile + checkExecTest = if null interpreterTests + then checkTest + else sequentialTestGroup path AllSucceed [checkTest, testGroup "execution" interpreterTests] + in tests {compileTests = compileTest:compileTests, checkExecTests = checkExecTest:checkExecTests } From 3aea4e8dca2500c590457509615094484301e397 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 15:13:12 +0100 Subject: [PATCH 097/149] regroup parse+check+compile+exec under each example --- brat/test/Test/Checking.hs | 7 ++-- brat/test/Test/Compile/Hugr.hs | 4 +-- brat/test/Test/Examples.hs | 65 +++++++++++++++------------------- 3 files changed, 35 insertions(+), 41 deletions(-) diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index 1d7b922c..ddd7e77f 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -1,4 +1,4 @@ -module Test.Checking (parseAndCheck) where +module Test.Checking (parseAndCheck, parseAndCheckNamed) where import Brat.Load import Brat.Naming (root) @@ -8,7 +8,10 @@ import Test.Tasty import Test.Tasty.HUnit parseAndCheck :: [FilePath] -> FilePath -> TestTree -parseAndCheck libDirs file = testCase (show file) $ do +parseAndCheck libDirs file = parseAndCheckNamed (show file) libDirs file + +parseAndCheckNamed :: String -> [FilePath] -> FilePath -> TestTree +parseAndCheckNamed name libDirs file = testCase name $ do env <- runExceptT $ loadFilename root libDirs file case env of Left err -> assertFailure (show err) diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index e79f22fb..fe6f55c3 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -15,8 +15,8 @@ prefix = "test/compilation" examplesPrefix = "examples" outputDir = prefix "output" -compileToOutput :: FilePath -> TestTree -compileToOutput file = testCaseInfo (show file) $ do +compileToOutput :: String -> FilePath -> TestTree +compileToOutput name file = testCaseInfo name $ do createDirectoryIfMissing False outputDir compileFile [] file >>= \case Right hs -> mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, splices)) -> do diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index e142b5e0..1b926ac9 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -1,11 +1,10 @@ module Test.Examples (getExamplesTests) where -import Test.Checking (parseAndCheck) +import Test.Checking (parseAndCheckNamed) import Test.Compile.Hugr (compileToOutput) import Brat.Load (parseFile) import Brat.Machine (runInterpreter) -import Control.Monad (foldM) import Data.Char (isAlphaNum) import Data.Functor ((<&>)) import Data.List (isPrefixOf) @@ -17,13 +16,6 @@ import Test.Tasty.ExpectedFailure --import Debug.Trace -data Tests = Tests - { parseTests :: [TestTree] - , checkExecTests :: [TestTree] - , compileTests :: [TestTree] - } - - execTestPrefix :: T.Text execTestPrefix = T.pack "--!test " @@ -33,36 +25,35 @@ interpreterOutputPrefix = "Finished " getExamplesTests :: IO TestTree getExamplesTests = do paths <- findByExtension [".brat"] "examples" - ts <- foldM addTests (Tests [] [] []) paths - pure $ testGroup "examples" [ - testGroup "parsing" (parseTests ts), - testGroup "check_exec" (checkExecTests ts), - testGroup "compilation" (compileTests ts) - ] + testGroup "examples" <$> mapM mkTest paths where - addTests :: Tests -> FilePath -> IO Tests - addTests tests@Tests{..} path = readFile path <&> \cts -> - let parseTest = testCase (show path) $ do + mkTest :: FilePath -> IO TestTree + mkTest path = readFile path <&> \cts -> + let parseTest = do case parseFile path cts of Left err -> assertFailure (show err) Right _ -> return () -- OK - checkTest = parseAndCheck [] path + checkTest = parseAndCheckNamed "checking" [] path in if isPrefixOf "--!xfail-parsing" cts then - tests { parseTests = (expectFail parseTest):parseTests } - else if isPrefixOf "--!xfail-checking" cts then - tests { parseTests = parseTest:parseTests, checkExecTests = (expectFail checkTest):checkExecTests } - else - let compileTest = if isPrefixOf "--!xfail-compilation" cts then expectFail (compileToOutput path) else compileToOutput path - interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> - let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start - expectedOutput = interpreterOutputPrefix ++ T.unpack (T.drop (T.length execTestPrefix) testLine) - -- this repeats/roughly duplicates the logic for "identifiers" in the parser - func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn) - in testCase func_name $ do - -- this completely recompiles the file for each test, which is pretty bad - output <- runInterpreter [] path func_name - assertEqual ("Interpreter output for " ++ func_name) expectedOutput (T.unpack output) - checkExecTest = if null interpreterTests - then checkTest - else sequentialTestGroup path AllSucceed [checkTest, testGroup "execution" interpreterTests] - in tests {compileTests = compileTest:compileTests, checkExecTests = checkExecTest:checkExecTests } + expectFail (testCase (show path) parseTest) + else if isPrefixOf "--!xfail-checking" cts then testGroup (show path) [ + testCase "parsing" parseTest, + expectFail checkTest] + else + let interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> + let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start + expectedOutput = interpreterOutputPrefix ++ T.unpack (T.drop (T.length execTestPrefix) testLine) + -- this repeats/roughly duplicates the logic for "identifiers" in the parser + func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn) + in testCase func_name $ do + -- this completely recompiles the file for each test, which is pretty bad + output <- runInterpreter [] path func_name + expectedOutput @?= (T.unpack output) + in case (interpreterTests, isPrefixOf "--!xfail-compilation" cts) of + ([], True) -> testGroup (show path) $ [checkTest, expectFail (compileToOutput "compilation" path)] + ([], False) -> compileToOutput path path + (intTests, xfcomp) -> + let compileTest = compileToOutput "compilation" path + in sequentialTestGroup path AllSucceed ( + (if xfcomp then [checkTest, expectFail compileTest] else [compileTest]) + ++ interpreterTests) \ No newline at end of file From 3cf7052fbf1c61975bd3b1fdf8702654f6c25f21 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 20:51:39 +0100 Subject: [PATCH 098/149] simplify by allowing singleton group, but parallelize execution tests --- brat/test/Test/Examples.hs | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index 1b926ac9..c0d57309 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -29,17 +29,16 @@ getExamplesTests = do where mkTest :: FilePath -> IO TestTree mkTest path = readFile path <&> \cts -> - let parseTest = do + let parseTest = testCase "parsing" $ do case parseFile path cts of Left err -> assertFailure (show err) Right _ -> return () -- OK checkTest = parseAndCheckNamed "checking" [] path in if isPrefixOf "--!xfail-parsing" cts then - expectFail (testCase (show path) parseTest) - else if isPrefixOf "--!xfail-checking" cts then testGroup (show path) [ - testCase "parsing" parseTest, - expectFail checkTest] - else + testGroup (show path) [expectFail parseTest] + else if isPrefixOf "--!xfail-checking" cts then + testGroup (show path) [parseTest, expectFail checkTest] + else let interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start expectedOutput = interpreterOutputPrefix ++ T.unpack (T.drop (T.length execTestPrefix) testLine) @@ -49,11 +48,10 @@ getExamplesTests = do -- this completely recompiles the file for each test, which is pretty bad output <- runInterpreter [] path func_name expectedOutput @?= (T.unpack output) - in case (interpreterTests, isPrefixOf "--!xfail-compilation" cts) of - ([], True) -> testGroup (show path) $ [checkTest, expectFail (compileToOutput "compilation" path)] - ([], False) -> compileToOutput path path - (intTests, xfcomp) -> - let compileTest = compileToOutput "compilation" path - in sequentialTestGroup path AllSucceed ( - (if xfcomp then [checkTest, expectFail compileTest] else [compileTest]) - ++ interpreterTests) \ No newline at end of file + compileTest = compileToOutput "compilation" path + checkAndCompile = if isPrefixOf "--!xfail-compilation" cts + then [checkTest, expectFail compileTest] else [compileTest] + in case interpreterTests of + [] -> testGroup (show path) checkAndCompile + intTests -> sequentialTestGroup path AllSucceed + (checkAndCompile ++ [testGroup "execution" interpreterTests]) From 3cbf05aaba9855c3d3beb2525daa414e8440a36a Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 17 Apr 2026 21:06:23 +0100 Subject: [PATCH 099/149] Re-enable warnings, fix --- brat/Brat/Compile/Hugr.hs | 4 ++-- brat/Brat/Compiler.hs | 1 - brat/Brat/Machine.hs | 25 ++++++++++--------------- brat/brat.cabal | 4 ++++ 4 files changed, 16 insertions(+), 18 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 66b0a6bf..e73e5dc2 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -10,7 +10,7 @@ module Brat.Compile.Hugr (compileKernel, makeIO, makeCS, CompilationState(..), addEdge, addNode, Container(..), onHugr) where import Brat.Constructors.Patterns (pattern CFalse, pattern CTrue) -import Brat.Checker.Monad (track, trackM, CheckingSig(..), CaptureSets) +import Brat.Checker.Monad (track, trackM, CheckingSig(..)) import Brat.Checker.Helpers (binderToValue) import Brat.Checker.Types (Store(..)) import Brat.Eval (eval, evalCTy, kindType) @@ -581,7 +581,7 @@ undoPrimTest parent inPorts outTy (PrimLitTest tm) = do compileKernel :: (Namespace, Store, Graph) -> String -> Name -> (HugrGraph NodeId, [(NodeId, OutPort)]) -compileKernel (nsp, store, g@(ns, es)) desc name = (hgr, holelist) where +compileKernel (nsp, store, g@(ns, _)) desc name = (hgr, holelist) where (src_tgt, outs) = case ns M.! name of -- All top-level functions are compiled into Box-es, which should look like this: (BratNode (Box src tgt) [] outs) -> ((src, tgt), outs) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index a4ae0dd7..aa3af00e 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -28,7 +28,6 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import Data.Foldable (for_) import Data.HugrGraph (HugrGraph, NodeId, to_json) -import qualified Data.Map as M import System.Exit (die) printDeclsHoles :: [FilePath] -> String -> IO () diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 0dc2d383..8e55e89b 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -3,15 +3,12 @@ module Brat.Machine (runInterpreter) where import Brat.Checker.Monad (CaptureSets) import Brat.Checker.Types (Store, initStore) import Brat.Compiler (compileToGraph) ---import Brat.Compile.Hugr (compileKernel, makeIO, makeCS, addEdge, addNode, CompilationState(hugr), Container(..)) import Brat.Compile.Hugr import Brat.Constructors.Patterns import Brat.Naming (Name, Namespace, split) -import qualified Brat.Naming as Naming -import Brat.Graph (Graph, NodeType (..), Node (BratNode, KernelNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..), emptyGraph) +import Brat.Graph (Graph, NodeType (..), Node (BratNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..), emptyGraph) import Brat.QualName (QualName, plain) import Brat.Syntax.Simple (SimpleTerm(..)) -import Brat.Syntax.Port (OutPort(..)) import Brat.Syntax.Common import Brat.Syntax.Value @@ -29,8 +26,6 @@ import qualified Data.Set as S import Bwd import Util (zipSameLength) -import Debug.Trace - type GraphInfo = (Graph, Store, Namespace, CaptureSets) runInterpreter :: [FilePath] -> String -> String -> IO T.Text @@ -128,16 +123,16 @@ run :: GraphInfo -> Bwd Frame -> Task -> Task --run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined -- Tasks that push new frames onto the stack to do things -run gi@(g@(nodes, wires), _, _, _) fz (EvalPort p@(Ex name offset)) = case lookupOutport fz p of +run gi fz (EvalPort p@(Ex name _)) = case lookupOutport fz p of Just v -> run gi fz (Use v) Nothing -> evalNodeInputs gi (fz :< AwaitNodeInputs p) name -run gi@(g@(nodes, _), st, root, cs) fz t@(EvalNode n ins) = case nodes M.! n of +run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of --nw | trace ("EVALNODE " ++ show nw) False -> undefined (BratNode (Const st) _ _) -> run gi fz (Finished [evalSimpleTerm st]) (BratNode (ArithNode op) _ _) -> run gi fz (Finished [evalArith op ins]) (BratNode Id _ _) -> run gi fz (Finished ins) (BratNode (Eval func) _ _) -> run gi (fz :< CallWith ins) (EvalPort func) - (BratNode (Box src tgt) [] [(_, VFun Kerny _)]) -> + (BratNode (Box _ _) [] [(_, VFun Kerny _)]) -> let (sub, newRoot) = split "box" root (hugr, splices) = compileKernel (sub, st, g) "box" n in evalSplices (g, st, newRoot, cs) fz hugr splices @@ -147,7 +142,7 @@ run gi@(g@(nodes, _), st, root, cs) fz t@(EvalNode n ins) = case nodes M.! n of in run gi fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) (BratNode (PatternMatch (c:|cs)) _ _) -> run gi (fz :< Alternatives (c:cs) ins) TryNextMatch (BratNode (Constructor c) _ _) -> run gi fz (Finished [evalConstructor c ins]) - (BratNode (Dummy k) _ _) -> run gi fz (Finished [DummyV]) + (BratNode (Dummy _) _ _) -> run gi fz (Finished [DummyV]) (BratNode (Prim (ext, op)) [] [(_, VFun Braty cty)]) -> run gi fz (Finished [ThunkV (BratPrim ext op cty)]) nw -> run gi fz (StuckOnNode n nw) @@ -164,13 +159,13 @@ run gi (fz :< DoSplices hugr nid rest) (Use v) = run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt -run gi@(g,st,ns,cs) (fz :< CallWith inputs) (Use (ThunkV (BratPrim ext op cty))) +run (g,st,ns,cs) (fz :< CallWith inputs) (Use (ThunkV (BratPrim ext op _cty))) | (hugrNS,newRoot) <- split "hugr" ns, Just outs <- runPrim hugrNS (ext,op) inputs = run (g,st,newRoot,cs) fz (Finished outs) ---- Finished (list of values) -run gi (fz :< AwaitNodeInputs req@(Ex name offset)) (Finished inputs) = +run gi (fz :< AwaitNodeInputs req@(Ex name _)) (Finished inputs) = run gi (fz :< SelectFromNodeOutputs req) (EvalNode name inputs) -run gi (fz :< SelectFromNodeOutputs req@(Ex name offset)) (Finished outputs) = +run gi (fz :< SelectFromNodeOutputs (Ex name offset)) (Finished outputs) = run gi (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] outputs]) (Use (outputs !! offset)) run gi (B0 :< ReturnTo fz) (Finished vals) = run gi fz (Finished vals) @@ -187,7 +182,7 @@ run gi (fz :< Alternatives ((TestMatchData _ ms, box):cs) ins) TryNextMatch = in run gi (fz :< CallWith vals) (EvalPort $ Ex box 0) run gi (fz :< BratValues _) t = run gi fz t -run gi B0 t = t +run _ B0 t = t run gi fz t = run gi fz (Suspend [] t) runPrim :: Namespace -> (String, String) -> [Value] -> Maybe [Value] @@ -326,7 +321,7 @@ testCtor CVec CRiffle (VecV vs) = do where evenOdds :: [a] -> Maybe ([a], [a]) evenOdds [] = pure ([], []) - evenOdds [x] = Nothing + evenOdds [_] = Nothing evenOdds (x:y:xs) = do (evens, odds) <- evenOdds xs pure (x:evens, y:odds) diff --git a/brat/brat.cabal b/brat/brat.cabal index abab64e6..f237c89e 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -44,7 +44,11 @@ common warning-flags -Wno-unused-do-bind -Wno-missing-signatures -Wno-noncanonical-monoid-instances + -Werror=unused-imports + -Werror=unused-matches -Werror=missing-methods + -Werror=unused-top-binds + -Werror=unused-local-binds -Werror=redundant-constraints -Werror=orphans -Werror=overlapping-patterns From 5af9f3780822464be7d0631f6365a82a4dddb9e2 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 20 Apr 2026 12:03:27 +0100 Subject: [PATCH 100/149] Remove the putStrLn 'Not an Id node', make 'not found in VEnv' an error --- brat/Brat/Compiler.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index aa3af00e..315f71d0 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -19,7 +19,6 @@ import Brat.QualName (QualName) import Brat.Syntax.Port (NamedPort(..), OutPort(..), InPort(..)) import Brat.Syntax.Value (Val(VFun)) - import Control.Exception (evaluate) import Control.Monad (forM, when) import Control.Monad.Except @@ -27,6 +26,7 @@ import Data.List (intercalate) import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import Data.Foldable (for_) +import Data.Traversable (for) import Data.HugrGraph (HugrGraph, NodeId, to_json) import System.Exit (die) @@ -96,20 +96,19 @@ compileFile libDirs file = do (newRoot, (declEnv, holes, st, outerGraph, _)) <- compileToGraph libDirs file let venv = M.map fst declEnv case holes of - [] -> do - box_decls <- concat <$> forM (M.keys declEnv) (findBoxes venv outerGraph) - Right <$> (evaluate -- turns 'error' into IO 'die' + [] -> let box_decls = (M.keys declEnv) >>= (findBoxes venv outerGraph) + in Right <$> (evaluate -- turns 'error' into IO 'die' $ M.fromList [(n, compileKernel (newRoot, st, outerGraph) "root" n) | n <- box_decls]) hs -> pure $ Left (CompilingHoles hs) where - findBoxes :: VEnv -> Graph -> QualName -> IO [Name] + findBoxes :: VEnv -> Graph -> QualName -> [Name] findBoxes venv (ns, es) name = case M.lookup name venv of - Nothing -> (putStrLn $ (show name) ++ ".... not found in VEnv") >> pure [] - Just vals -> concat <$> (forM vals $ \(NamedPort (Ex n _) _, _) -> -- so, this returns IO [Name] + Nothing -> error $ (show name) ++ ".... not found in VEnv" + Just vals -> concat (for vals $ \(NamedPort (Ex n _) _, _) -> -- so, this returns [Name] case M.lookup n ns of Just (BratNode Id _ _) -> - pure [src | (Ex src 0, _, In tgt _) <- es, tgt == n, isKernelBox src ns] - _ -> (putStrLn $ (show n) ++ ".... not an Id node") >> pure []) + [src | (Ex src 0, _, In tgt _) <- es, tgt == n, isKernelBox src ns] + _ -> []) isKernelBox :: Name -> M.Map Name Node -> Bool isKernelBox name ns = case M.lookup name ns of Just (BratNode (Box _ _ ) [] [(_, VFun Kerny _cty)]) -> True From 55e392982dd167306ac9cd9f6d4df1027b74bac5 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 20 Apr 2026 15:52:07 +0100 Subject: [PATCH 101/149] Change --!test to --!exec w/option -xfail, add tests in app.brat --- brat/examples/app.brat | 13 +++++++++++++ brat/examples/arith.brat | 14 +++++++------- brat/test/Test/Examples.hs | 16 +++++++++++----- 3 files changed, 31 insertions(+), 12 deletions(-) diff --git a/brat/examples/app.brat b/brat/examples/app.brat index aa2f64ac..acf6c075 100644 --- a/brat/examples/app.brat +++ b/brat/examples/app.brat @@ -4,3 +4,16 @@ if(_, false, _, else) = else() test(Bool) -> Nat test(b) = if(Nat, b, { => 4 }, { => 12 }) + +--!exec [4] +t :: Nat +t = test(true) + +--This is an 'xfail' in that the test is clearly wrong +--!exec-xfail [11] +f :: Nat +f = test(false) + +--!exec [12] +f' :: Nat +f' = f \ No newline at end of file diff --git a/brat/examples/arith.brat b/brat/examples/arith.brat index b41a42dd..48bf50ce 100644 --- a/brat/examples/arith.brat +++ b/brat/examples/arith.brat @@ -20,26 +20,26 @@ unary_minus(x) = x + -3.0 unary_minus2(Int) -> Int unary_minus2(x) = -2-x ---!test [7] +--!exec [7] i :: Nat i = 3 + 4 ---!test [-9] +--!exec [-9] j :: Int j = unary_minus2(7) ---!test [11.13] +--!exec [11.13] f :: Float f = 2.1 * 5.3 ---!test [3.3000000000000003] +--!exec [3.3000000000000003] g :: Float g = 7.2 - 3.9 inc(Nat) -> Nat inc(x) = x + 1 ---!test [14] +--!exec [14] foo :: Nat foo = inc(inc(4) + inc(7)) @@ -57,10 +57,10 @@ hoo(n :: #, Vec(Nat, n + 1)) -> Nat hoo(succ(l), ls =, m ,= rs) = length(!, !, ls) hoo(n, _) = n ---!test [1] +--!exec [1] ioo :: Nat ioo = hoo(2, [1,2,3]) ---!test [[1,2,3]] +--!exec [[1,2,3]] joo :: Vec(Nat, 3) joo = [1,2,3] diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index c0d57309..a00f5bd8 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -9,6 +9,7 @@ import Data.Char (isAlphaNum) import Data.Functor ((<&>)) import Data.List (isPrefixOf) import qualified Data.Text.Lazy as T +import Data.Maybe (fromJust) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver @@ -17,7 +18,7 @@ import Test.Tasty.ExpectedFailure --import Debug.Trace execTestPrefix :: T.Text -execTestPrefix = T.pack "--!test " +execTestPrefix = T.pack "--!exec" interpreterOutputPrefix :: String interpreterOutputPrefix = "Finished " @@ -41,17 +42,22 @@ getExamplesTests = do else let interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start - expectedOutput = interpreterOutputPrefix ++ T.unpack (T.drop (T.length execTestPrefix) testLine) + -- testLine begins with execTestPrefix, then either " " or "-xfail " and the expected result + restLine = fromJust $ T.stripPrefix execTestPrefix testLine + (is_xfail, eOut) = case T.stripPrefix (T.pack "-xfail ") restLine of + Just out -> (True, out) + Nothing -> (False, restLine) -- assume begins with space, will be removed here: + expectedOutput = interpreterOutputPrefix ++ T.unpack (T.strip eOut) -- this repeats/roughly duplicates the logic for "identifiers" in the parser func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn) - in testCase func_name $ do + in (if is_xfail then expectFail else id) $ testCase func_name $ do -- this completely recompiles the file for each test, which is pretty bad output <- runInterpreter [] path func_name - expectedOutput @?= (T.unpack output) + (T.unpack output) @?= expectedOutput compileTest = compileToOutput "compilation" path checkAndCompile = if isPrefixOf "--!xfail-compilation" cts then [checkTest, expectFail compileTest] else [compileTest] in case interpreterTests of [] -> testGroup (show path) checkAndCompile intTests -> sequentialTestGroup path AllSucceed - (checkAndCompile ++ [testGroup "execution" interpreterTests]) + (checkAndCompile ++ [testGroup "execution" intTests]) From 74a01a6b9c6844236f932a25088dedb1a253b7bc Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 20 Apr 2026 15:54:19 +0100 Subject: [PATCH 102/149] Add xfails (Suspend): brace-sections, batcher-merge-sort, cons, fanout, infer_thunks{,2} --- brat/examples/batcher-merge-sort.brat | 5 +++++ brat/examples/brace-sections.brat | 10 ++++++++-- brat/examples/cons.brat | 6 ++++-- brat/examples/fanout.brat | 5 +++++ brat/examples/infer_thunks.brat | 1 + brat/examples/infer_thunks2.brat | 1 + brat/test/Test/Examples.hs | 4 +++- 7 files changed, 27 insertions(+), 5 deletions(-) diff --git a/brat/examples/batcher-merge-sort.brat b/brat/examples/batcher-merge-sort.brat index f7ec0a63..e72bd5f0 100644 --- a/brat/examples/batcher-merge-sort.brat +++ b/brat/examples/batcher-merge-sort.brat @@ -26,6 +26,7 @@ merge(succ(n), xs0 =%= xs1, ys0 =%= ys1) -- or even: -- = merge(n, xs0, ys0) =%= merge(n, xs1, ys1) |> -- (zs => fixOffBy1(n, zs)) +-- but the elaborator doesn't synthesize the type of the list before fixOffBy1 -- Example of how to write with vectorising `of` @@ -33,3 +34,7 @@ fixOffBy1(n :: #, Vec(Nat, 2^(n + 1))) -> Vec(Nat, 2^(n + 1)) fixOffBy1(n, lo ,- (mid0 =%= mid1) -, hi) = let mid0', mid1' = (full(n) of cas)(mid0, mid1) in lo ,- (mid0' =%= mid1') -, hi + +--!exec-xfail [[2,3,4,5,6,7,11,12]] +test_merge :: Vec(Nat, 8) +test_merge = merge(2, [2,5,7,11], [3, 4, 6, 12]) \ No newline at end of file diff --git a/brat/examples/brace-sections.brat b/brat/examples/brace-sections.brat index 6723c7b6..cdb0ab2f 100644 --- a/brat/examples/brace-sections.brat +++ b/brat/examples/brace-sections.brat @@ -15,6 +15,10 @@ id = { _ } use5 :: { Int -> Int } use5 = { _ |> (id,be5); add } +--!exec [9] +test_use5 :: Int +test_use5 = use5(4) + add5 :: { Int -> Int } add5 = {add(_, 5)} --> { '0 => add('0, 5) } @@ -35,8 +39,10 @@ swap = { snd:_,_ } -- be5' :: Int -- be5' = be5() --> 5 +--!exec [6] add5' :: Int -add5' = add5(1) --> 6 +add5' = add5(1) +--!exec [3] add__' :: Int -add__' = add__(1,2) --> 3 +add__' = add__(1,2) diff --git a/brat/examples/cons.brat b/brat/examples/cons.brat index 036bf4ec..af0c1b84 100644 --- a/brat/examples/cons.brat +++ b/brat/examples/cons.brat @@ -20,6 +20,7 @@ three :: Int three = add(twoThings) -- Is equivalent to: +--!exec [3] three' :: Int three' = let x, y = twoThings in add(x, y) @@ -34,8 +35,9 @@ uncons(cons(x, xs)) = x, xs -- However, on the right hand side, something that represents the right number -- of values can be used as the argument to a cons -dup(Int) -> List(Int) -dup(n) = cons(uncons([1,2,3])) +--!exec [[1,2,3]] +dup :: List(Int) +dup = cons(uncons([1,2,3])) -- Just like a regular function application: pair(Int, Int) -> [Int, Int] diff --git a/brat/examples/fanout.brat b/brat/examples/fanout.brat index ff3afa57..cbde9b16 100644 --- a/brat/examples/fanout.brat +++ b/brat/examples/fanout.brat @@ -4,6 +4,11 @@ open import lib.kernel (CX) fanout(Vec(Nat, 3)) -> Nat, Nat, Nat fanout = { [/\] } +-- note a single Vec output would be [[3,5,7]] +--!exec [3,5,7] +test_fanout :: Nat, Nat, Nat +test_fanout = fanout([3,5,7]) + swap(X :: $, Y :: $) -> { X, Y -o Y, X } swap(_, _) = { x, y => y, x } diff --git a/brat/examples/infer_thunks.brat b/brat/examples/infer_thunks.brat index 1030efc5..b3939065 100644 --- a/brat/examples/infer_thunks.brat +++ b/brat/examples/infer_thunks.brat @@ -7,5 +7,6 @@ map(X :: *, Y :: *, { X -> Y }, List(X)) -> List(Y) map(_, _, _, []) = [] map(X, Y, f, x ,- xs) = f(x) ,- map(X, Y, f, xs) +--!exec-xfail [[5.0]] test :: List(Float) test = map(!, !, {f => f(5)}, [to_float]) diff --git a/brat/examples/infer_thunks2.brat b/brat/examples/infer_thunks2.brat index d9006b1a..217ff361 100644 --- a/brat/examples/infer_thunks2.brat +++ b/brat/examples/infer_thunks2.brat @@ -7,5 +7,6 @@ map(X :: *, Y :: *, List(X), { X -> Y }) -> List(Y) map(_, _, [], _) = [] map(X, Y, x ,- xs, f) = f(x) ,- map(X, Y, xs, f) +--!exec-xfail [[5.0]] test :: List(Float) test = map(!, !, [to_float], {f => f(5)}) diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index a00f5bd8..448f9034 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -46,7 +46,9 @@ getExamplesTests = do restLine = fromJust $ T.stripPrefix execTestPrefix testLine (is_xfail, eOut) = case T.stripPrefix (T.pack "-xfail ") restLine of Just out -> (True, out) - Nothing -> (False, restLine) -- assume begins with space, will be removed here: + Nothing -> case T.stripPrefix (T.pack " ") restLine of + Just out -> (False, out) + Nothing -> error "Invalid test line, should start with '--!exec[-xfail] '" expectedOutput = interpreterOutputPrefix ++ T.unpack (T.strip eOut) -- this repeats/roughly duplicates the logic for "identifiers" in the parser func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn) From f30f52bbad6ebe18a1d030c42a129dbf9e3bec9b Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 20 Apr 2026 16:40:11 +0100 Subject: [PATCH 103/149] infer{,2}.brat: remove repeated/commented-out-repeats, inc. of eatsfull.bis --- brat/examples/infer.brat | 52 +++++++++------------------------------ brat/examples/infer2.brat | 17 ------------- 2 files changed, 11 insertions(+), 58 deletions(-) diff --git a/brat/examples/infer.brat b/brat/examples/infer.brat index f1eaf0bf..a4fcaeb5 100644 --- a/brat/examples/infer.brat +++ b/brat/examples/infer.brat @@ -6,48 +6,18 @@ mapVec(X :: *, Y :: *, { X -> Y }, n :: #, Vec(X, n)) -> Vec(Y, n) mapVec(_, _, _, _, []) = [] mapVec(_, _, f, _, x ,- xs) = f(x) ,- mapVec(!, !, f, !, xs) ---map(X :: *, Y :: *, { X -> Y }, List(X)) -> List(Y) ---map(_, _, _, []) = [] ---map(_, _, f, x ,- xs) = f(x) ,- map(!, !, f, xs) ---mapVec(X :: *, Y :: *, { X -> Y }, n :: #, Vec(X, n)) -> Vec(Y, n) ---mapVec(_, _, _, _, []) = [] ---mapVec(_, _, f, n, x ,- xs) = f(x) ,- mapVec(!, !, f, !, xs) - ---length(X :: *, n :: #, Vec(X, n)) -> (m :: #) ---length(_, n, []) = n ---length(_, n, x ,- xs) = n - --- The "succ" still being required in both of these cases is https://github.com/CQCL/brat/issues/35 +length(X :: *, n :: #, Vec(X, n)) -> (m :: #) +length(_, n, []) = n +length(_, n, x ,- xs) = n -- While map above can infer the holes from the other arguments, -- here we need to infer the holes (arguments) from the results: --- repeat(X :: *, n :: #, x :: X) -> Vec(X, n) --- repeat(_, 0, _) = [] --- repeat(_, succ(_), x) = x ,- repeat(!, !, x) -- X can be inferred from x but n cannot --- --- mapFirst(X :: *, Y :: *, { X -> Y}, n :: #, Vec(X, n)) -> Vec(Y, n) --- mapFirst(_, _, _, _, []) = [] --- mapFirst(_, _, f, succ(_), x ,- _) = repeat(!, !, f(x)) -- first ! (X) is second _ (Y) --- --- isfull(n :: #) -> Bool --- isfull(succ(doub(n))) = isfull(n) --- isfull(0) = true --- isfull(_) = false --- --- hasfulllen(n :: #, Vec(Bool, n)) -> Bool --- hasfulllen(n, x ,- (xs =,= ys)) = hasfulllen(!, xs) --- hasfulllen(_, []) = true --- hasfulllen(_, _) = false --- --- eatsfull(n :: #, xs :: Vec(Bool, full(n))) -> Nat --- eatsfull(n, _) = n --- mkftwo :: Nat --- mkftwo = eatsfull(!, [false,false,false]) --- --- eatsodd(n :: #, xs :: Vec(Bool, succ(doub(n)))) -> Nat --- eatsodd(n, _) = n --- mkotwo' :: Nat --- mkotwo' = eatsodd(2, [false,false,false,false,false]) --- mkotwo :: Nat --- mkotwo = eatsodd(!, [false,false,false,false,false]) +repeat(X :: *, n :: #, x :: X) -> Vec(X, n) +repeat(_, 0, _) = [] +repeat(_, succ(_), x) = x ,- repeat(!, !, x) -- X can be inferred from x but n cannot + +mapFirst(X :: *, Y :: *, { X -> Y}, n :: #, Vec(X, n)) -> Vec(Y, n) +mapFirst(_, _, _, _, []) = [] +mapFirst(_, _, f, succ(_), x ,- _) = repeat(!, !, f(x)) -- first ! (X) is second _ (Y) + diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat index 421e2eb7..b42bb965 100644 --- a/brat/examples/infer2.brat +++ b/brat/examples/infer2.brat @@ -1,15 +1,3 @@ --- The "succ" still being required in both of these cases is https://github.com/CQCL/brat/issues/35 - --- While some cases can infer the holes from the other arguments, --- here we need to infer the holes (arguments) from the results: -repeat(X :: *, n :: #, x :: X) -> Vec(X, n) -repeat(_, 0, _) = [] -repeat(_, succ(_), x) = x ,- repeat(!, !, x) -- X can be inferred from x but n cannot - -mapFirst(X :: *, Y :: *, { X -> Y}, n :: #, Vec(X, n)) -> Vec(Y, n) -mapFirst(_, _, _, _, []) = [] -mapFirst(_, _, f, succ(_), x ,- _) = repeat(!, !, f(x)) -- first ! (X) is second _ (Y) - isfull(n :: #) -> Bool isfull(succ(doub(n))) = isfull(n) isfull(0) = true @@ -20,11 +8,6 @@ hasfulllen(n, x ,- (xs =,= ys)) = hasfulllen(!, xs) hasfulllen(_, []) = true hasfulllen(_, _) = false -eatsfull(n :: #, xs :: Vec(Bool, full(n))) -> Nat -eatsfull(n, _) = n -mkftwo :: Nat -mkftwo = eatsfull(!, [false,false,false]) - eatsodd(n :: #, xs :: Vec(Bool, succ(doub(n)))) -> Nat eatsodd(n, _) = n mkotwo' :: Nat From 977c695c77bdea2e4e2664775399f08ecf6efa4a Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 20 Apr 2026 17:23:06 +0100 Subject: [PATCH 104/149] infer.brat: add vector tests (passing w/ typechecking workaround) --- brat/examples/infer.brat | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/brat/examples/infer.brat b/brat/examples/infer.brat index a4fcaeb5..b6ec5a2e 100644 --- a/brat/examples/infer.brat +++ b/brat/examples/infer.brat @@ -6,6 +6,13 @@ mapVec(X :: *, Y :: *, { X -> Y }, n :: #, Vec(X, n)) -> Vec(Y, n) mapVec(_, _, _, _, []) = [] mapVec(_, _, f, _, x ,- xs) = f(x) ,- mapVec(!, !, f, !, xs) +-- This is needed as a temporary workaround for https://github.com/Quantinuum/brat/issues/109 +inc(Nat) -> Nat +inc(x) = x + 1 + +--!exec [[5,7,9]] +test_mapVec :: Vec(Nat, 3) +test_mapVec = mapVec(!,!, inc, !, [4,6,8]) length(X :: *, n :: #, Vec(X, n)) -> (m :: #) length(_, n, []) = n @@ -21,3 +28,6 @@ mapFirst(X :: *, Y :: *, { X -> Y}, n :: #, Vec(X, n)) -> Vec(Y, n) mapFirst(_, _, _, _, []) = [] mapFirst(_, _, f, succ(_), x ,- _) = repeat(!, !, f(x)) -- first ! (X) is second _ (Y) +--!exec [[5,5,5,5,5]] +test_mapFirst :: Vec(Nat, 5) +test_mapFirst = mapFirst(!, !, inc, !, [4,6,7,8,9]) From 501da843add505c9daf75feea0c97faec790bf4c Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Mon, 20 Apr 2026 17:25:39 +0100 Subject: [PATCH 105/149] infer2.brat: tests that work --- brat/examples/infer2.brat | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat index b42bb965..5833e83e 100644 --- a/brat/examples/infer2.brat +++ b/brat/examples/infer2.brat @@ -3,14 +3,23 @@ isfull(succ(doub(n))) = isfull(n) isfull(0) = true isfull(_) = false +--!exec [False] +is5full :: Bool +is5full = isfull(5) + hasfulllen(n :: #, Vec(Bool, n)) -> Bool hasfulllen(n, x ,- (xs =,= ys)) = hasfulllen(!, xs) hasfulllen(_, []) = true hasfulllen(_, _) = false +--!exec [True] +hasfulllen3 :: Bool +hasfulllen3 = hasfulllen(!, [false, false, false]) + eatsodd(n :: #, xs :: Vec(Bool, succ(doub(n)))) -> Nat eatsodd(n, _) = n mkotwo' :: Nat mkotwo' = eatsodd(2, [false,false,false,false,false]) + mkotwo :: Nat mkotwo = eatsodd(!, [false,false,false,false,false]) From 2b055cbc40e91f5c2302df4d903cb0b6b345efca Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 15:43:29 +0100 Subject: [PATCH 106/149] infer2.brat: tests that produce wrong answer - suspect wrong graph --- brat/examples/infer2.brat | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat index 5833e83e..90c08c34 100644 --- a/brat/examples/infer2.brat +++ b/brat/examples/infer2.brat @@ -3,6 +3,14 @@ isfull(succ(doub(n))) = isfull(n) isfull(0) = true isfull(_) = false +--!exec [True] +is3full :: Bool +is3full = isfull(3) + +--!exec [True] +is15full :: Bool +is15full = isfull(15) + --!exec [False] is5full :: Bool is5full = isfull(5) From 56fee119948403a550f322986e41e381fc6a0565 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 15:49:08 +0100 Subject: [PATCH 107/149] Revert "infer2.brat: tests that produce wrong answer - suspect wrong graph" This reverts commit 2b055cbc40e91f5c2302df4d903cb0b6b345efca. --- brat/examples/infer2.brat | 8 -------- 1 file changed, 8 deletions(-) diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat index 90c08c34..5833e83e 100644 --- a/brat/examples/infer2.brat +++ b/brat/examples/infer2.brat @@ -3,14 +3,6 @@ isfull(succ(doub(n))) = isfull(n) isfull(0) = true isfull(_) = false ---!exec [True] -is3full :: Bool -is3full = isfull(3) - ---!exec [True] -is15full :: Bool -is15full = isfull(15) - --!exec [False] is5full :: Bool is5full = isfull(5) From 31acde47f7fc31c3fa6569e48469af4177535da4 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 15:49:46 +0100 Subject: [PATCH 108/149] infer2.brat: test that fails with 'index too large' in Machine.hs --- brat/examples/infer2.brat | 1 + 1 file changed, 1 insertion(+) diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat index 5833e83e..13a4d843 100644 --- a/brat/examples/infer2.brat +++ b/brat/examples/infer2.brat @@ -21,5 +21,6 @@ eatsodd(n, _) = n mkotwo' :: Nat mkotwo' = eatsodd(2, [false,false,false,false,false]) +--!exec [2] mkotwo :: Nat mkotwo = eatsodd(!, [false,false,false,false,false]) From 0c66214730aa3a622270ccfb5933d3a329b641bc Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 10:48:56 +0100 Subject: [PATCH 109/149] Rm map.brat, included in infer.brat --- brat/examples/map.brat | 3 --- 1 file changed, 3 deletions(-) delete mode 100644 brat/examples/map.brat diff --git a/brat/examples/map.brat b/brat/examples/map.brat deleted file mode 100644 index db7b558d..00000000 --- a/brat/examples/map.brat +++ /dev/null @@ -1,3 +0,0 @@ -map(X :: *, Y :: *, { X -> Y }, List(X)) -> List(Y) -map(_, _, _, []) = [] -map(_, _, f, x ,- xs) = f(x) ,- map(!, !, f, xs) From eb88823ae61db88bf30dff04737c17f55edb3166 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 17:14:20 +0100 Subject: [PATCH 110/149] runInterpreter returns either Text or HugrGraph --- brat/Brat/Machine.hs | 7 +++---- brat/app/Main.hs | 11 +++++++++-- brat/test/Test/Examples.hs | 5 +++-- 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 8e55e89b..ed75f820 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -12,7 +12,6 @@ import Brat.Syntax.Simple (SimpleTerm(..)) import Brat.Syntax.Common import Brat.Syntax.Value -import Data.Aeson.Text (encodeToLazyText) import Data.Hugr import qualified Data.HugrGraph as HG import Hasochism @@ -28,7 +27,7 @@ import Util (zipSameLength) type GraphInfo = (Graph, Store, Namespace, CaptureSets) -runInterpreter :: [FilePath] -> String -> String -> IO T.Text +runInterpreter :: [FilePath] -> String -> String -> IO (Either T.Text (HG.HugrGraph HG.NodeId)) runInterpreter libDirs file runFunc = do (root, (declEnv, _, st, outerGraph, capSets)) <- compileToGraph libDirs file let venv = M.map fst declEnv @@ -37,8 +36,8 @@ runInterpreter libDirs file runFunc = do let outTask = evalPorts (outerGraph, st, root, capSets) (B0 :< BratValues M.empty) B0 outPorts -- we hope outTask is a Finished. Or a Suspend. pure $ case outTask of - Finished [(KernelV hugr)] -> encodeToLazyText (HG.serialize hugr) - _ -> T.pack $ show outTask + Finished [(KernelV hugr)] -> Right hugr + _ -> Left $ T.pack $ show outTask data Frame where BratValues :: EvalEnv -> Frame diff --git a/brat/app/Main.hs b/brat/app/Main.hs index e58db877..3acaa413 100644 --- a/brat/app/Main.hs +++ b/brat/app/Main.hs @@ -1,6 +1,9 @@ import Brat.Compiler import Brat.Machine (runInterpreter) +import qualified Data.ByteString.Lazy as BS (putStr) +import Data.HugrGraph (to_json) + import Data.Text.Lazy.IO (putStr) import Control.Monad (when) import Options.Applicative @@ -47,5 +50,9 @@ main = do let libDirs = parseLibs libs when (dot /= "") $ writeDot libDirs file dot if compile then compileAndPrintFile libDirs file - else if runFunc /= "" then runInterpreter libDirs file runFunc >>= putStr - else printDeclsHoles libDirs file + else if runFunc == "" then printDeclsHoles libDirs file + else do + result <- runInterpreter libDirs file runFunc + case result of + Right hugr -> BS.putStr (to_json hugr) + Left s -> putStr s diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index 448f9034..a6af13f7 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -54,8 +54,9 @@ getExamplesTests = do func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn) in (if is_xfail then expectFail else id) $ testCase func_name $ do -- this completely recompiles the file for each test, which is pretty bad - output <- runInterpreter [] path func_name - (T.unpack output) @?= expectedOutput + runInterpreter [] path func_name >>= \case + Left t -> T.unpack t @?= expectedOutput + Right _ -> assertFailure $ "Expected output: '" ++ expectedOutput ++ "' but got a hugr!" compileTest = compileToOutput "compilation" path checkAndCompile = if isPrefixOf "--!xfail-compilation" cts then [checkTest, expectFail compileTest] else [compileTest] From 070982f6bda6ba414336f2d19c67b23ab1e1fb41 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 17:18:49 +0100 Subject: [PATCH 111/149] HugrGraph: hide root, add getRoot/getNodes --- brat/Brat/Compile/Hugr.hs | 4 ++-- brat/Brat/Machine.hs | 2 +- brat/Data/HugrGraph.hs | 9 ++++++++- brat/test/Test/HugrGraph.hs | 4 ++-- 4 files changed, 13 insertions(+), 6 deletions(-) diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index e73e5dc2..ec0e7d2d 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -15,7 +15,7 @@ import Brat.Checker.Helpers (binderToValue) import Brat.Checker.Types (Store(..)) import Brat.Eval (eval, evalCTy, kindType) import Brat.Graph hiding (lookupNode) -import Brat.Naming hiding (root) +import Brat.Naming import Brat.QualName import Brat.Syntax.Port import Brat.Syntax.Common @@ -590,7 +590,7 @@ compileKernel (nsp, store, g@(ns, _)) desc name = (hgr, holelist) where [(_, VFun Kerny cty)] -> cty (startHugr, nsp') = runState (H.new desc (OpDFG $ DFG (FunctionType hInTys hOutTys bratExts) [])) nsp (hgr, holelist) = flip evalState (makeCS (g, nsp', store) startHugr) $ do - ctr <- makeIO desc (root startHugr) + ctr <- makeIO desc (H.getRoot startHugr) compileBox ctr src_tgt hugr <- gets hugr hs <- gets holes diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index ed75f820..48219704 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -193,7 +193,7 @@ makeParametrisedGateHugr :: Namespace -> {- Op name: -} String -> {- angle arg: makeParametrisedGateHugr ns op th nqubits = let (ns', newRoot) = split "" ns in hugr $ flip execState (makeCS (emptyGraph, newRoot, initStore) (dfgHugr ns')) $ do - parent <- gets (HG.root . hugr) + parent <- gets (HG.getRoot . hugr) Ctr {parent,input,output} <- makeIO "" parent onHugr $ HG.setOp input (OpIn (InputNode [HTQubit, HTQubit] [])) onHugr $ HG.setOp output (OpOut (OutputNode [HTQubit, HTQubit] [])) diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index a99ea561..5c76f531 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Data.HugrGraph(NodeId, - HugrGraph(root), -- do NOT export contents, keep abstract + HugrGraph, -- do NOT export contents, keep abstract new, freshNode, + getRoot, getNodes, setFirstChildren, setOp, getParent, getOp, addEdge, addOrderEdge, @@ -28,6 +29,12 @@ track = const id newtype NodeId = NodeId Name deriving (Eq, Ord, Show) +getRoot :: HugrGraph n -> n +getRoot HugrGraph {root} = root + +getNodes :: HugrGraph n -> [n] +getNodes HugrGraph {parents, root} = root:(M.keys parents) + data HugrGraph n = HugrGraph { root :: n, parents :: M.Map n n, -- definitive list of (valid) nodes, excluding root diff --git a/brat/test/Test/HugrGraph.hs b/brat/test/Test/HugrGraph.hs index a9d93953..7e4ef08e 100644 --- a/brat/test/Test/HugrGraph.hs +++ b/brat/test/Test/HugrGraph.hs @@ -49,7 +49,7 @@ testSplice inline prepend = testCaseInfo name $ do name = (if inline then "inline" else "noinline") ++ (if prepend then "_prepend" else "_new") host :: (NodeId, (HugrGraph NodeId, Namespace)) host = flip runState (runState (H.new "root" rootDefn) N.root) $ do - root <- get <&> H.root . fst + root <- get <&> H.getRoot . fst input <- addNode "inp" root (OpIn (InputNode tys [])) output <- addNode "out" root (OpOut (OutputNode tys [])) jh $setFirstChildren root [input, output] @@ -63,7 +63,7 @@ testSplice inline prepend = testCaseInfo name $ do dfgHugr = let (initHugr, ns) = runState (H.new "root" rootDfg) N.root in fst $ flip execState (initHugr, ns) $ do - root <- get <&> H.root . fst + root <- get <&> H.getRoot . fst input <- addNode "inp" root (OpIn (InputNode tys [])) output <- addNode "out" root (OpOut (OutputNode tys [])) jh $ setFirstChildren root [input, output] From 6c8236604c247e7e8e1d7be3182a1effb8a46e0a Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 17:19:31 +0100 Subject: [PATCH 112/149] Test/Compile/Hugr.hs: add getSplices, compileToOutput checks they match --- brat/test/Test/Compile/Hugr.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index fe6f55c3..7047a7db 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -1,9 +1,6 @@ -module Test.Compile.Hugr where +module Test.Compile.Hugr (compileToOutput, getSplices) where import Control.Monad (forM) -import Data.HugrGraph (to_json) -import Brat.Compiler (compileFile, CompilingHoles(..)) - import qualified Data.Map as M import qualified Data.ByteString as BS import System.Directory (createDirectoryIfMissing) @@ -11,8 +8,13 @@ import System.FilePath import Test.Tasty import Test.Tasty.HUnit +import Data.Hugr (isHole) +import Data.HugrGraph (to_json, getOp, HugrGraph, getNodes) +import Data.List (sort) +import Data.Maybe (isJust) +import Brat.Compiler (compileFile, CompilingHoles(..)) + prefix = "test/compilation" -examplesPrefix = "examples" outputDir = prefix "output" compileToOutput :: String -> FilePath -> TestTree @@ -20,6 +22,7 @@ compileToOutput name file = testCaseInfo name $ do createDirectoryIfMissing False outputDir compileFile [] file >>= \case Right hs -> mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, splices)) -> do + sort (getSplices hugr) @?= sort (map fst splices) -- ignore splices for now let outFile = outputDir replaceExtension (takeFileName file) ((show boxName) ++ ".json") -- lots of fun with lazy and even strict bytestrings @@ -27,3 +30,6 @@ compileToOutput name file = testCaseInfo name $ do BS.writeFile outFile $! (BS.toStrict $ to_json hugr) pure $ "Written to " ++ outFile ++ " pending validation\n") Left (CompilingHoles _) -> pure "Skipped as contains holes" + +getSplices :: Ord a => HugrGraph a -> [a] +getSplices hg = [n | n <- getNodes hg, isJust (isHole $ getOp hg n)] \ No newline at end of file From b2c624cc6f2e6999243d9987bc1654b11be3311d Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 17:22:19 +0100 Subject: [PATCH 113/149] add --!exec-hugr that checks no splices, writes to test/examples/output, validates --- brat/examples/qft.brat | 4 ++++ brat/test/Test/Examples.hs | 41 ++++++++++++++++++++++++++++---------- brat/tools/validate.sh | 2 +- 3 files changed, 36 insertions(+), 11 deletions(-) diff --git a/brat/examples/qft.brat b/brat/examples/qft.brat index 99bf0a31..641bfb0f 100644 --- a/brat/examples/qft.brat +++ b/brat/examples/qft.brat @@ -29,3 +29,7 @@ qft(succ(n)) = { |, qft(n); recons(n) } + +--!exec-hugr +test_qft(Vec(Qubit, 5)) -o Vec(Qubit, 5) +test_qft = qft(5) diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index a6af13f7..df729d20 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -1,15 +1,19 @@ module Test.Examples (getExamplesTests) where import Test.Checking (parseAndCheckNamed) -import Test.Compile.Hugr (compileToOutput) +import Test.Compile.Hugr (compileToOutput, getSplices) import Brat.Load (parseFile) import Brat.Machine (runInterpreter) +import Data.HugrGraph (to_json) +import qualified Data.ByteString as BS import Data.Char (isAlphaNum) import Data.Functor ((<&>)) import Data.List (isPrefixOf) import qualified Data.Text.Lazy as T import Data.Maybe (fromJust) +import System.Directory (createDirectoryIfMissing) +import System.FilePath import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver @@ -17,6 +21,9 @@ import Test.Tasty.ExpectedFailure --import Debug.Trace +outputDir :: FilePath +outputDir = "test/examples/output" + execTestPrefix :: T.Text execTestPrefix = T.pack "--!exec" @@ -42,17 +49,31 @@ getExamplesTests = do else let interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) -> let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start - -- testLine begins with execTestPrefix, then either " " or "-xfail " and the expected result - restLine = fromJust $ T.stripPrefix execTestPrefix testLine - (is_xfail, eOut) = case T.stripPrefix (T.pack "-xfail ") restLine of - Just out -> (True, out) - Nothing -> case T.stripPrefix (T.pack " ") restLine of - Just out -> (False, out) - Nothing -> error "Invalid test line, should start with '--!exec[-xfail] '" - expectedOutput = interpreterOutputPrefix ++ T.unpack (T.strip eOut) -- this repeats/roughly duplicates the logic for "identifiers" in the parser func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn) - in (if is_xfail then expectFail else id) $ testCase func_name $ do + -- testLine begins with execTestPrefix, then either + -- " " and the expected result + -- "-xfail " and the (un-)expected result + -- "-hugr\n" (checks no splices, outputs hugr for validation) + restLine = fromJust $ T.stripPrefix execTestPrefix testLine + in if (T.pack "-hugr") == restLine then testCaseInfo func_name $ do + let outFile = outputDir dropExtension (takeFileName path) ++ "_" ++ func_name <.> "json" + -- this completely recompiles the file for each test, which is pretty bad + hugr <- runInterpreter [] path func_name >>= \case + Left s -> assertFailure $ "Expected hugr, got " ++ T.unpack s + Right hugr -> pure hugr + getSplices hugr @?= [] + -- output the hugr for validation + createDirectoryIfMissing False outputDir + BS.writeFile outFile $! (BS.toStrict $ to_json hugr) + pure $ "Written hugr to " ++ outFile ++ " pending validation" + else + let (is_xfail, eOut) = case T.stripPrefix (T.pack "-xfail ") restLine of + Just out -> (True, out) + Nothing | Just out <- T.stripPrefix (T.pack " ") restLine -> (False, out) + | otherwise -> error $ "Invalid exec test line: " ++ T.unpack testLine + expectedOutput = interpreterOutputPrefix ++ T.unpack (T.strip eOut) + in (if is_xfail then expectFail else id) $ testCase func_name $ do -- this completely recompiles the file for each test, which is pretty bad runInterpreter [] path func_name >>= \case Left t -> T.unpack t @?= expectedOutput diff --git a/brat/tools/validate.sh b/brat/tools/validate.sh index e8f234d5..ffeb47bf 100755 --- a/brat/tools/validate.sh +++ b/brat/tools/validate.sh @@ -12,7 +12,7 @@ declare -a FAILED_TEST_MSGS UNEXPECTED_PASSES= NUM_FAILURES=0 -for dir in test/compilation/output test/hugr/output; do +for dir in test/compilation/output test/examples/output test/hugr/output; do for json in $(find $dir -maxdepth 1 -name "*.json"); do echo Validating "$json" RESULT=$(cat "$json" | hugr_validator 2>&1) From ba113a7cb2a5cf53630abc3b51a344e86208798b Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 21 Apr 2026 16:21:35 +0100 Subject: [PATCH 114/149] Fix bogus add def in examples --- brat/examples/brace-sections.brat | 3 ++- brat/examples/cons.brat | 5 +++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/brat/examples/brace-sections.brat b/brat/examples/brace-sections.brat index cdb0ab2f..94e77c4f 100644 --- a/brat/examples/brace-sections.brat +++ b/brat/examples/brace-sections.brat @@ -1,4 +1,5 @@ -ext "" add(x :: Int, y :: Int) -> (z :: Int) +add(x :: Int, y :: Int) -> (z :: Int) +add(x,y) = x + y be5 :: { -> Int } be5 = { => 5 } diff --git a/brat/examples/cons.brat b/brat/examples/cons.brat index af0c1b84..f565abb6 100644 --- a/brat/examples/cons.brat +++ b/brat/examples/cons.brat @@ -1,4 +1,5 @@ -ext "" add(Int, Int) -> Int +add(Int, Int) -> Int +add(x, y) = x + y copy(Int) -> Int, Int copy(x) = x, x @@ -17,7 +18,7 @@ goodBinding = let x, y = twoThings in x, y -- Functions can be applied directly to things that -- represent the right number of values three :: Int -three = add(twoThings) +three = add(twoThings) -- Is equivalent to: --!exec [3] From d6942bcd64f8ce728a424f6fcfc3bae66a856ec8 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 21 Apr 2026 16:35:48 +0100 Subject: [PATCH 115/149] Machine: Add list constructors to pattern matching --- brat/Brat/Machine.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 48219704..db09471e 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -310,6 +310,8 @@ testCtor CNat CZero (IntV 0) = Just [] testCtor CNat CSucc (IntV x) | x > 0 = Just [IntV (x - 1)] testCtor CVec CNil (VecV []) = Just [] testCtor CVec CCons (VecV (v:vs)) = Just [v, VecV vs] +testCtor CList CNil (VecV []) = Just [] +testCtor CList CCons (VecV (v:vs)) = Just [v, VecV vs] testCtor CVec CConcatEqEven (VecV vs) = do (half, 0) <- pure (length vs `divMod` 2) (xs, ys) <- pure (splitAt half vs) From 83d27b2a32544716437cfd0e7413b0d0aace7ef0 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 21 Apr 2026 17:42:30 +0100 Subject: [PATCH 116/149] xfail remaining tests --- brat/examples/fanout.brat | 4 +++- brat/examples/infer2.brat | 5 ++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/brat/examples/fanout.brat b/brat/examples/fanout.brat index cbde9b16..02067f61 100644 --- a/brat/examples/fanout.brat +++ b/brat/examples/fanout.brat @@ -4,8 +4,10 @@ open import lib.kernel (CX) fanout(Vec(Nat, 3)) -> Nat, Nat, Nat fanout = { [/\] } +-- XFAIL: Requires handling selectors in the exec test which we want to get rid of! -- note a single Vec output would be [[3,5,7]] ---!exec [3,5,7] +--!exec-xfail [3,5,7] + test_fanout :: Nat, Nat, Nat test_fanout = fanout([3,5,7]) diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat index 13a4d843..222a1c51 100644 --- a/brat/examples/infer2.brat +++ b/brat/examples/infer2.brat @@ -18,9 +18,12 @@ hasfulllen3 = hasfulllen(!, [false, false, false]) eatsodd(n :: #, xs :: Vec(Bool, succ(doub(n)))) -> Nat eatsodd(n, _) = n + +--!exec [2] mkotwo' :: Nat mkotwo' = eatsodd(2, [false,false,false,false,false]) ---!exec [2] +-- Executing with ! doesn't seem to work. See #111 +--!exec-xfail [2] mkotwo :: Nat mkotwo = eatsodd(!, [false,false,false,false,false]) From 34071914111bc6c91d90935ac65748c8cbb632fd Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Tue, 21 Apr 2026 15:43:29 +0100 Subject: [PATCH 117/149] infer2.brat: xfailed tests that produce wrong answer - suspect wrong graph --- brat/examples/infer2.brat | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat index 222a1c51..5e6af0ec 100644 --- a/brat/examples/infer2.brat +++ b/brat/examples/infer2.brat @@ -3,6 +3,16 @@ isfull(succ(doub(n))) = isfull(n) isfull(0) = true isfull(_) = false +-- https://github.com/Quantinuum/brat/issues/112 +--!exec-xfail [True] +is3full :: Bool +is3full = isfull(3) + +-- https://github.com/Quantinuum/brat/issues/112 +--!exec-xfail [True] +is15full :: Bool +is15full = isfull(15) + --!exec [False] is5full :: Bool is5full = isfull(5) From f267f4a16ecd8db4b7b457f5507e1da4701cd3a7 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 09:45:16 +0100 Subject: [PATCH 118/149] move examples output --- brat/test/Test/Examples.hs | 2 +- brat/tools/validate.sh | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index df729d20..1a371e80 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -22,7 +22,7 @@ import Test.Tasty.ExpectedFailure --import Debug.Trace outputDir :: FilePath -outputDir = "test/examples/output" +outputDir = "test" "examples" execTestPrefix :: T.Text execTestPrefix = T.pack "--!exec" diff --git a/brat/tools/validate.sh b/brat/tools/validate.sh index ffeb47bf..7a9d414a 100755 --- a/brat/tools/validate.sh +++ b/brat/tools/validate.sh @@ -12,7 +12,7 @@ declare -a FAILED_TEST_MSGS UNEXPECTED_PASSES= NUM_FAILURES=0 -for dir in test/compilation/output test/examples/output test/hugr/output; do +for dir in test/compilation/output test/examples test/hugr/output; do for json in $(find $dir -maxdepth 1 -name "*.json"); do echo Validating "$json" RESULT=$(cat "$json" | hugr_validator 2>&1) @@ -22,12 +22,12 @@ for dir in test/compilation/output test/examples/output test/hugr/output; do NUM_FAILURES=$((NUM_FAILURES + 1)) fi done +done - for invalid_json in $(find test/compilation/output -maxdepth 1 -name "*.json.invalid"); do - if (hugr_validator < $invalid_json 2>/dev/null > /dev/null); then - UNEXPECTED_PASSES="$UNEXPECTED_PASSES $invalid_json" - fi - done +for invalid_json in $(find test/compilation/output -maxdepth 1 -name "*.json.invalid"); do + if (hugr_validator < $invalid_json 2>/dev/null > /dev/null); then + UNEXPECTED_PASSES="$UNEXPECTED_PASSES $invalid_json" + fi done RED='\033[0;31m' From 3c0571aeac71efd75938ea8f8ae95489d84d96c3 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 10:22:57 +0100 Subject: [PATCH 119/149] Fix adder.brat test --- brat/examples/adder.brat | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/brat/examples/adder.brat b/brat/examples/adder.brat index 8a2749ef..ce1ca32a 100644 --- a/brat/examples/adder.brat +++ b/brat/examples/adder.brat @@ -1,4 +1,3 @@ ---!xfail-checking xor(Bool, Bool) -> Bool xor(false, b) = b xor(a, false) = a @@ -50,7 +49,7 @@ fastAdder(n :: #, Vec(Bool, 2^n), Vec(Bool, 2^n), carryIn :: Bool) -> carryOut : fastAdder(0, [x], [y], b) = let c, z = fullAdder(x, y, b) in c, [z] fastAdder(succ(n), xsh =,= xsl, ysh =,= ysl, b) = fastAdder(n, xsh, ysh, true), fastAdder(n, xsh, ysh, false), fastAdder(n, xsl, ysl, b) |> - (d1, zsh1, d0, zsh0, c, zsl => if(Bool, c, d1, d0), if(Vec(Bool, succ(full(n))), c, zsh1, zsh0) =,= zsl) + (d1, zsh1, d0, zsh0, c, zsl => if(Bool, c, d1, d0), if(!, c, zsh1, zsh0) =,= zsl) chop(n :: #, Vec(Bool, 2 * n)) -> Vec(Bool, n), Vec(Bool, n) chop(n, hi =,= lo) = hi, lo From 91bfde2b4bfa6faac685d8ab616201bcdbdd0042 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 10:29:31 +0100 Subject: [PATCH 120/149] Remove undercooked hea example --- brat/examples/hea.brat | 40 ---------------------------------------- 1 file changed, 40 deletions(-) delete mode 100644 brat/examples/hea.brat diff --git a/brat/examples/hea.brat b/brat/examples/hea.brat deleted file mode 100644 index 18c47f40..00000000 --- a/brat/examples/hea.brat +++ /dev/null @@ -1,40 +0,0 @@ ---!xfail-checking --- Playing with representing a hardware-efficient ansatz - --- Expectation: --- - this file parses and typechecks - --- Reality: --- - the parser is struggling with variables being plugged into the end of vectors - -open import lib.kernel - -type Real = Nat -- Temporary hack - -type Operator = [[Nat, Nat],Real] - -type Pauli = Vec(Nat, 0) - -edges :: Vec(Operator, 1) -edges = ?e - -numNodes :: Nat -numNodes = ?nn - -numEdges :: Nat -numEdges = ?ne - -apply_operators :: { Vec(Money, numNodes) - , Vec(Operator, numEdges) - -o Vec(Qubit, numNodes) - } -apply_operators = ?help - --- map :: (f :: {A -> B}), (xs :: Vec A n) -> (ys :: Vec B n) --- map = f, xs => ?ys - -hea(rotations :: Vec (Operator, numEdges) - ,meas :: Vec (Pauli ,numNodes) - ,(cash :: Vec (Money ,numNodes))) - -> (cash :: Vec (Money ,numNodes)), (result :: Vec(Bool, numNodes)) -hea = rots, meas => ?j -- apply-operators; meas(cash); xs => map(measure,xs); transpose From 37f220952fdceaf81a491e5dbad8c53212e24ecc Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 10:29:43 +0100 Subject: [PATCH 121/149] Fix infer_thunks exec tests --- brat/examples/infer_thunks.brat | 4 ++-- brat/examples/infer_thunks2.brat | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/brat/examples/infer_thunks.brat b/brat/examples/infer_thunks.brat index b3939065..c553e841 100644 --- a/brat/examples/infer_thunks.brat +++ b/brat/examples/infer_thunks.brat @@ -1,4 +1,4 @@ -ext "to_float" to_float(i :: Int) -> Float +ext "arith.i2f" to_float(i :: Int) -> Float id(X :: *, X) -> X id(_, x) = x @@ -7,6 +7,6 @@ map(X :: *, Y :: *, { X -> Y }, List(X)) -> List(Y) map(_, _, _, []) = [] map(X, Y, f, x ,- xs) = f(x) ,- map(X, Y, f, xs) ---!exec-xfail [[5.0]] +--!exec [[5.0]] test :: List(Float) test = map(!, !, {f => f(5)}, [to_float]) diff --git a/brat/examples/infer_thunks2.brat b/brat/examples/infer_thunks2.brat index 217ff361..654af54a 100644 --- a/brat/examples/infer_thunks2.brat +++ b/brat/examples/infer_thunks2.brat @@ -1,4 +1,4 @@ -ext "to_float" to_float(i :: Int) -> Float +ext "arith.i2f" to_float(i :: Int) -> Float id(X :: *, X) -> X id(_, x) = x @@ -7,6 +7,6 @@ map(X :: *, Y :: *, List(X), { X -> Y }) -> List(Y) map(_, _, [], _) = [] map(X, Y, x ,- xs, f) = f(x) ,- map(X, Y, xs, f) ---!exec-xfail [[5.0]] +--!exec [[5.0]] test :: List(Float) test = map(!, !, [to_float], {f => f(5)}) From 2bf223802a75fc3e9733a0bed515e055508f21e7 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 10:43:27 +0100 Subject: [PATCH 122/149] Delete redundant karlheinz_alias test --- brat/examples/karlheinz_alias.brat | 21 --------------------- 1 file changed, 21 deletions(-) delete mode 100644 brat/examples/karlheinz_alias.brat diff --git a/brat/examples/karlheinz_alias.brat b/brat/examples/karlheinz_alias.brat deleted file mode 100644 index f9b5e6cb..00000000 --- a/brat/examples/karlheinz_alias.brat +++ /dev/null @@ -1,21 +0,0 @@ ---!xfail-checking --- This is a subset of the karlheinz.brat test file - --- Expectation: --- - The type of the input to exp expands to --- `{ Vec Qubit 2 -o Vec Bool 2 }` --- - The type of the input to execute expands to --- `{Vec Qubit 2 -o Vec Bool 1}` - --- Reality: --- - Type checking fails, as currently arguments to type aliases must all be of kind '*' (these are '#') - -type Dist = List(Bool) -type KCirc(q, b) = { Vec(Qubit, q) -o Vec(Bool, b) } -type PCirc(q) = { Vec(Qubit, q) -o Vec(Bool, q) } - -exp(PCirc(2)) -> Dist -exp = ?exp - -execute(KCirc(2, 1)) -> Dist -execute = ?a From b0457aa6718794118cdf5a93ce1d726c130f2a53 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 10:57:11 +0100 Subject: [PATCH 123/149] Add missing extension to brat_extension --- hugr_extension/src/lib.rs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hugr_extension/src/lib.rs b/hugr_extension/src/lib.rs index fc2a549b..42c9d5b3 100644 --- a/hugr_extension/src/lib.rs +++ b/hugr_extension/src/lib.rs @@ -9,7 +9,7 @@ use hugr::{ simple_op::{MakeOpDef, MakeRegisteredOp}, ExtensionId, ExtensionRegistry, ExtensionSet, TypeDefBound, }, - std_extensions::{arithmetic::int_types, collections}, + std_extensions::{arithmetic::{float_types,int_types}, collections}, types::{type_param::TypeParam, CustomType, Type, TypeArg, TypeBound, TypeName, TypeRV}, Extension, }; @@ -49,6 +49,7 @@ lazy_static! { pub static ref BRAT_OPS_REGISTRY: ExtensionRegistry = ExtensionRegistry::try_new([ prelude::PRELUDE.to_owned(), int_types::EXTENSION.to_owned(), + float_types::EXTENSION.to_owned(), collections::EXTENSION.to_owned(), EXTENSION.to_owned(), ]) From 0f7679b19a95754e3898300507bba66c1a6ecd9b Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 11:09:19 +0100 Subject: [PATCH 124/149] No point in CompilationResult returning OutPorts of lost Graph; getSplices -> getHoles --- brat/Brat/Compiler.hs | 8 +++++--- brat/test/Test/Compile/Hugr.hs | 10 +++++----- brat/test/Test/Examples.hs | 4 ++-- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index 315f71d0..0a4f3c35 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -88,8 +88,8 @@ compileToGraph libDirs file = do env <- runExceptT $ loadFilename checkRoot libDirs file (newRoot,) <$> eitherIO env --- Map from box name to (compiled graph, list of splices) -type CompilationResult = M.Map Name (HugrGraph NodeId, [(NodeId, OutPort)]) +-- Map from box name to (compiled hugr, list of hole nodes in it) +type CompilationResult = M.Map Name (HugrGraph NodeId, [NodeId]) compileFile :: [FilePath] -> String -> IO (Either CompilingHoles CompilationResult) compileFile libDirs file = do @@ -98,7 +98,9 @@ compileFile libDirs file = do case holes of [] -> let box_decls = (M.keys declEnv) >>= (findBoxes venv outerGraph) in Right <$> (evaluate -- turns 'error' into IO 'die' - $ M.fromList [(n, compileKernel (newRoot, st, outerGraph) "root" n) | n <- box_decls]) + $ M.fromList [(n, let (hugr, holes) = compileKernel (newRoot, st, outerGraph) "root" n + in (hugr, map fst holes)) + | n <- box_decls]) hs -> pure $ Left (CompilingHoles hs) where findBoxes :: VEnv -> Graph -> QualName -> [Name] diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 7047a7db..1551f85c 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -1,4 +1,4 @@ -module Test.Compile.Hugr (compileToOutput, getSplices) where +module Test.Compile.Hugr (compileToOutput, getHoles) where import Control.Monad (forM) import qualified Data.Map as M @@ -21,8 +21,8 @@ compileToOutput :: String -> FilePath -> TestTree compileToOutput name file = testCaseInfo name $ do createDirectoryIfMissing False outputDir compileFile [] file >>= \case - Right hs -> mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, splices)) -> do - sort (getSplices hugr) @?= sort (map fst splices) + Right hs -> mconcat <$> (forM (M.toList hs) $ \(boxName, (hugr, holes)) -> do + sort (getHoles hugr) @?= sort holes -- ignore splices for now let outFile = outputDir replaceExtension (takeFileName file) ((show boxName) ++ ".json") -- lots of fun with lazy and even strict bytestrings @@ -31,5 +31,5 @@ compileToOutput name file = testCaseInfo name $ do pure $ "Written to " ++ outFile ++ " pending validation\n") Left (CompilingHoles _) -> pure "Skipped as contains holes" -getSplices :: Ord a => HugrGraph a -> [a] -getSplices hg = [n | n <- getNodes hg, isJust (isHole $ getOp hg n)] \ No newline at end of file +getHoles :: Ord a => HugrGraph a -> [a] +getHoles hg = [n | n <- getNodes hg, isJust (isHole $ getOp hg n)] \ No newline at end of file diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index 1a371e80..41c547ff 100644 --- a/brat/test/Test/Examples.hs +++ b/brat/test/Test/Examples.hs @@ -1,7 +1,7 @@ module Test.Examples (getExamplesTests) where import Test.Checking (parseAndCheckNamed) -import Test.Compile.Hugr (compileToOutput, getSplices) +import Test.Compile.Hugr (compileToOutput, getHoles) import Brat.Load (parseFile) import Brat.Machine (runInterpreter) import Data.HugrGraph (to_json) @@ -62,7 +62,7 @@ getExamplesTests = do hugr <- runInterpreter [] path func_name >>= \case Left s -> assertFailure $ "Expected hugr, got " ++ T.unpack s Right hugr -> pure hugr - getSplices hugr @?= [] + getHoles hugr @?= [] -- output the hugr for validation createDirectoryIfMissing False outputDir BS.writeFile outFile $! (BS.toStrict $ to_json hugr) From b81b2c6654936ac5fe85bc546c9e4d38c9b2d41a Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 11:10:27 +0100 Subject: [PATCH 125/149] clarify xfail comment --- brat/examples/app.brat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/examples/app.brat b/brat/examples/app.brat index acf6c075..4652034a 100644 --- a/brat/examples/app.brat +++ b/brat/examples/app.brat @@ -9,7 +9,7 @@ test(b) = if(Nat, b, { => 4 }, { => 12 }) t :: Nat t = test(true) ---This is an 'xfail' in that the test is clearly wrong +--This is an 'xfail' as the expected value is clearly/deliberately wrong --!exec-xfail [11] f :: Nat f = test(false) From b82e277ed4ca73f14346a1eeec562521ca8b4be9 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 11:14:00 +0100 Subject: [PATCH 126/149] add tiny hugr test in kernel.brat --- brat/examples/kernel.brat | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/brat/examples/kernel.brat b/brat/examples/kernel.brat index 4897e84e..0d894fed 100644 --- a/brat/examples/kernel.brat +++ b/brat/examples/kernel.brat @@ -9,8 +9,12 @@ H = ?und Rz(th :: Float)-> {a::Qubit -o b::Qubit} Rz = ?rz -pba(Float)-> {c :: Qubit,d::Qubit -o c::Qubit,d::Qubit} +pba(Float) -> {c :: Qubit,d::Qubit -o c::Qubit,d::Qubit} pba = th => { x, y => (lib.kernel.H, |)(x, y) } +--!exec-hugr +test_pba(Qubit, Qubit) -o Qubit, Qubit +test_pba = pba(0.314) + th :: {Bool -> Bool} th = ?th From 289f19d775f17e9154d4dd3a4fd11d0f311a1c97 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 11:17:20 +0100 Subject: [PATCH 127/149] simplify some funcs in Compiler.hs --- brat/Brat/Compiler.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index 0a4f3c35..9b031ac5 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -26,7 +26,6 @@ import Data.List (intercalate) import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import Data.Foldable (for_) -import Data.Traversable (for) import Data.HugrGraph (HugrGraph, NodeId, to_json) import System.Exit (die) @@ -106,15 +105,14 @@ compileFile libDirs file = do findBoxes :: VEnv -> Graph -> QualName -> [Name] findBoxes venv (ns, es) name = case M.lookup name venv of Nothing -> error $ (show name) ++ ".... not found in VEnv" - Just vals -> concat (for vals $ \(NamedPort (Ex n _) _, _) -> -- so, this returns [Name] - case M.lookup n ns of + Just vals -> vals >>= \(NamedPort (Ex n _) _, _) -> case M.lookup n ns of Just (BratNode Id _ _) -> [src | (Ex src 0, _, In tgt _) <- es, tgt == n, isKernelBox src ns] - _ -> []) + _ -> [] isKernelBox :: Name -> M.Map Name Node -> Bool - isKernelBox name ns = case M.lookup name ns of - Just (BratNode (Box _ _ ) [] [(_, VFun Kerny _cty)]) -> True - _ -> False + isKernelBox name ns + | Just (BratNode (Box _ _ ) [] [(_, VFun Kerny _cty)]) <- M.lookup name ns = True + | otherwise = False compileAndPrintFile :: [FilePath] -> String -> IO () compileAndPrintFile libDirs file = compileFile libDirs file >>= \case From 493e89043a8a0accc7babeb9c22eb1ee58c4dbae Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 11:30:10 +0100 Subject: [PATCH 128/149] Get fanout test running --- brat/Brat/Machine.hs | 6 +++--- brat/examples/fanout.brat | 4 +--- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index db09471e..e81f2f1d 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -7,7 +7,7 @@ import Brat.Compile.Hugr import Brat.Constructors.Patterns import Brat.Naming (Name, Namespace, split) import Brat.Graph (Graph, NodeType (..), Node (BratNode), wiresTo, MatchSequence (..), PrimTest (..), TestMatchData (..), emptyGraph) -import Brat.QualName (QualName, plain) +import Brat.QualName (QualName(..), plain) import Brat.Syntax.Simple (SimpleTerm(..)) import Brat.Syntax.Common import Brat.Syntax.Value @@ -143,6 +143,8 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of (BratNode (Constructor c) _ _) -> run gi fz (Finished [evalConstructor c ins]) (BratNode (Dummy _) _ _) -> run gi fz (Finished [DummyV]) (BratNode (Prim (ext, op)) [] [(_, VFun Braty cty)]) -> run gi fz (Finished [ThunkV (BratPrim ext op cty)]) + (BratNode (Selector stor) _ _) -> case (stor, ins) of + (PrefixName [] "cons", [VecV (x:xs)]) -> run gi fz (Finished [x, VecV xs]) nw -> run gi fz (StuckOnNode n nw) -- Tasks that unwind the stack looking for what to do with the result @@ -231,8 +233,6 @@ makeParametrisedGateHugr ns op th nqubits = , args = [] } - - miniEval :: GraphInfo -> EvalEnv -> OutPort -> Value miniEval _ env x | Just v <- M.lookup x env = v miniEval gi@((nodes, _), _, _, _) env (Ex node 0) = diff --git a/brat/examples/fanout.brat b/brat/examples/fanout.brat index 02067f61..cbde9b16 100644 --- a/brat/examples/fanout.brat +++ b/brat/examples/fanout.brat @@ -4,10 +4,8 @@ open import lib.kernel (CX) fanout(Vec(Nat, 3)) -> Nat, Nat, Nat fanout = { [/\] } --- XFAIL: Requires handling selectors in the exec test which we want to get rid of! -- note a single Vec output would be [[3,5,7]] ---!exec-xfail [3,5,7] - +--!exec [3,5,7] test_fanout :: Nat, Nat, Nat test_fanout = fanout([3,5,7]) From d17da8ec8100241ea629ac139fad813dd8b44531 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 11:30:20 +0100 Subject: [PATCH 129/149] Expand link in comment --- brat/examples/infer2.brat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat index 5e6af0ec..f743f682 100644 --- a/brat/examples/infer2.brat +++ b/brat/examples/infer2.brat @@ -33,7 +33,7 @@ eatsodd(n, _) = n mkotwo' :: Nat mkotwo' = eatsodd(2, [false,false,false,false,false]) --- Executing with ! doesn't seem to work. See #111 +-- https://github.com/Quantinuum/brat/issues/111 --!exec-xfail [2] mkotwo :: Nat mkotwo = eatsodd(!, [false,false,false,false,false]) From 43bb48a4310d1fe58b488b26676c75d367e70f11 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 12:27:20 +0100 Subject: [PATCH 130/149] Add missing cases to Machine --- brat/Brat/Constructors/Patterns.hs | 3 ++- brat/Brat/Machine.hs | 4 ++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/brat/Brat/Constructors/Patterns.hs b/brat/Brat/Constructors/Patterns.hs index 1388d159..4fd6fac1 100644 --- a/brat/Brat/Constructors/Patterns.hs +++ b/brat/Brat/Constructors/Patterns.hs @@ -2,10 +2,11 @@ module Brat.Constructors.Patterns where import Brat.QualName -pattern CSucc, CDoub, CNil, CCons, CSome, CNone, CTrue, CFalse, CZero, CSnoc, +pattern CSucc, CDoub, CFull, CNil, CCons, CSome, CNone, CTrue, CFalse, CZero, CSnoc, CConcatEqEven, CConcatEqOdd, CRiffle :: QualName pattern CSucc = PrefixName [] "succ" pattern CDoub = PrefixName [] "doub" +pattern CFull = PrefixName [] "full" pattern CNil = PrefixName [] "nil" pattern CSome = PrefixName [] "some" pattern CNone = PrefixName [] "none" diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index e81f2f1d..a4457e1e 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -145,6 +145,8 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of (BratNode (Prim (ext, op)) [] [(_, VFun Braty cty)]) -> run gi fz (Finished [ThunkV (BratPrim ext op cty)]) (BratNode (Selector stor) _ _) -> case (stor, ins) of (PrefixName [] "cons", [VecV (x:xs)]) -> run gi fz (Finished [x, VecV xs]) + (BratNode Replicate _ _) -> case ins of + [IntV n, elem] -> run gi fz (Finished [(VecV (replicate n elem))]) nw -> run gi fz (StuckOnNode n nw) -- Tasks that unwind the stack looking for what to do with the result @@ -250,6 +252,7 @@ evalConstructor CFalse [] = BoolV False evalConstructor CZero [] = IntV 0 evalConstructor CSucc [IntV n] = IntV (n + 1) evalConstructor CDoub [IntV n] = IntV (2 * n) +evalConstructor CFull [IntV n] = IntV ((2 ^ n) - 1) evalConstructor CNil [] = VecV [] evalConstructor CCons [hd, VecV tl] = VecV (hd:tl) evalConstructor CSnoc [VecV tl, hd] = VecV (tl ++ [hd]) @@ -310,6 +313,7 @@ testCtor CNat CZero (IntV 0) = Just [] testCtor CNat CSucc (IntV x) | x > 0 = Just [IntV (x - 1)] testCtor CVec CNil (VecV []) = Just [] testCtor CVec CCons (VecV (v:vs)) = Just [v, VecV vs] +testCtor CVec CSnoc (VecV vs@(_:_)) = Just [VecV (init vs), last vs] testCtor CList CNil (VecV []) = Just [] testCtor CList CCons (VecV (v:vs)) = Just [v, VecV vs] testCtor CVec CConcatEqEven (VecV vs) = do From febbf793a74825f2fb017e9cb47266837cf7a388 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 12:28:26 +0100 Subject: [PATCH 131/149] [WIP] bits and pieces for implementing MapFun in Machine --- brat/Brat/Machine.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index a4457e1e..bb7ba896 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -55,6 +55,7 @@ data Frame where Alternatives :: [(TestMatchData Brat, Name)] -> [Value] -> Frame PerformMatchTests :: [(Src, PrimTest (BinderType Brat))] -> [(Src, BinderType Brat)] -> Name -> Frame DoSplices :: HG.HugrGraph HG.NodeId -> HG.NodeId -> [(HG.NodeId, OutPort)] -> Frame + ApplyMapFun :: [Value] -> Frame divider = replicate 78 '-' @@ -147,6 +148,9 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of (PrefixName [] "cons", [VecV (x:xs)]) -> run gi fz (Finished [x, VecV xs]) (BratNode Replicate _ _) -> case ins of [IntV n, elem] -> run gi fz (Finished [(VecV (replicate n elem))]) + (BratNode MapFun _ _) -> case ins of + -- We have a vector of functions + [IntV len, VecV fun] -> _ nw -> run gi fz (StuckOnNode n nw) -- Tasks that unwind the stack looking for what to do with the result @@ -345,6 +349,7 @@ data Value = | ThunkV BratThunk | KernelV (HG.HugrGraph HG.NodeId) | DummyV + | VecThunkV [Value] data BratThunk = -- this might want to be [EvalEnv] or something like that From 9a4a05e5a9b56cfd86731741a7f479a6667f0944 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 15:17:17 +0100 Subject: [PATCH 132/149] implement MapFun, factor out runThunk --- brat/Brat/Machine.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index bb7ba896..58ef9785 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -122,6 +122,13 @@ evalSplices gi fz hugr ((nid, outport):rest) = run :: GraphInfo -> Bwd Frame -> Task -> Task --run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined +runThunk :: GraphInfo -> Bwd Frame -> BratThunk -> [Value] -> Task +runThunk gi fz (BratClosure env src tgt) inputs = + let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] + in evalNodeInputs gi (fz :< (BratValues env_with_args)) tgt +runThunk (g,st,ns,cs) fz (BratPrim ext op _cty) inputs + | (hugrNS,newRoot) <- split "hugr" ns, Just outs <- runPrim hugrNS (ext,op) inputs = run (g,st,newRoot,cs) fz (Finished outs) + -- Tasks that push new frames onto the stack to do things run gi fz (EvalPort p@(Ex name _)) = case lookupOutport fz p of Just v -> run gi fz (Use v) @@ -150,7 +157,9 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of [IntV n, elem] -> run gi fz (Finished [(VecV (replicate n elem))]) (BratNode MapFun _ _) -> case ins of -- We have a vector of functions - [IntV len, VecV fun] -> _ + [IntV len, VecV funs] -> if len == length funs + then run gi fz (Finished [VecThunkV $ map (\(ThunkV t) -> t) funs]) + else error $ "MapFun length argument " ++ show len ++ " doesn't match length of function vector " ++ show (length funs) nw -> run gi fz (StuckOnNode n nw) -- Tasks that unwind the stack looking for what to do with the result @@ -163,11 +172,7 @@ run gi (fz :< DoSplices hugr nid rest) (Use v) = let (KernelV sub_hugr) = v hugr' = execState (HG.splice_prepend nid sub_hugr) hugr in evalSplices gi fz hugr' rest -run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = - let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] - in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt -run (g,st,ns,cs) (fz :< CallWith inputs) (Use (ThunkV (BratPrim ext op _cty))) - | (hugrNS,newRoot) <- split "hugr" ns, Just outs <- runPrim hugrNS (ext,op) inputs = run (g,st,newRoot,cs) fz (Finished outs) +run gi (fz :< CallWith inputs) (Use (ThunkV th)) = runThunk gi (B0 :< ReturnTo fz) th inputs ---- Finished (list of values) run gi (fz :< AwaitNodeInputs req@(Ex name _)) (Finished inputs) = @@ -349,7 +354,7 @@ data Value = | ThunkV BratThunk | KernelV (HG.HugrGraph HG.NodeId) | DummyV - | VecThunkV [Value] + | VecThunkV [BratThunk] -- Vectorised thunk, result of MapFun data BratThunk = -- this might want to be [EvalEnv] or something like that @@ -363,6 +368,7 @@ instance Show Value where show (VecV xs) = show xs show (ThunkV _) = "" show (KernelV k) = "Kernel (" ++ show k ++ ")" + show (VecThunkV ths) = "" show DummyV = "Dummy" type EvalEnv = M.Map OutPort Value From 49976940cc27dcea0713e448e76695eecbef15b3 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 16:21:10 +0100 Subject: [PATCH 133/149] VectorisedFuncs (frame), plus runVectorisedThunks -> test passes --- brat/Brat/Machine.hs | 38 ++++++++++++++++++++++++--- brat/examples/batcher-merge-sort.brat | 2 +- 2 files changed, 36 insertions(+), 4 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 58ef9785..deb64931 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -18,7 +18,8 @@ import Hasochism import Control.Monad.State (execState, gets, evalState) import qualified Data.Text.Lazy as T -import Data.Maybe (fromMaybe, fromJust) +import Data.Maybe (fromMaybe, fromJust, isNothing) +import Data.List (uncons) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as M import qualified Data.Set as S @@ -55,7 +56,8 @@ data Frame where Alternatives :: [(TestMatchData Brat, Name)] -> [Value] -> Frame PerformMatchTests :: [(Src, PrimTest (BinderType Brat))] -> [(Src, BinderType Brat)] -> Name -> Frame DoSplices :: HG.HugrGraph HG.NodeId -> HG.NodeId -> [(HG.NodeId, OutPort)] -> Frame - ApplyMapFun :: [Value] -> Frame + -- Remaining thunks with their inputs, and rows output by prior thunks + VectorisedFuncs :: [(BratThunk, [Value])] -> Bwd [Value] -> Frame divider = replicate 78 '-' @@ -75,7 +77,7 @@ showFrame (ReturnTo fz) = "ReturnTo" : (("> " ++) <$> showFrames fz) showFrame (Alternatives matches vz) = ["Alternatives", show matches, show vz] showFrame (PerformMatchTests tests srcs node) = ["PerformMatchTests", show tests, show srcs, show node] -- TODO showFrame (DoSplices hg src hugrs) = ["DoSplices", show hg, show src, show hugrs] - +showFrame (VectorisedFuncs ths outs) = ["VectorisedFuncs", "remaining " ++ show (length ths) ++ " thunks", show outs] showFrames :: Bwd Frame -> [String] showFrames = foldMap (\f -> divider : showFrame f) @@ -119,6 +121,20 @@ evalSplices gi fz hugr [] = run gi fz (Finished [KernelV hugr]) evalSplices gi fz hugr ((nid, outport):rest) = run gi (fz :< DoSplices hugr nid rest) (EvalPort outport) +runVectorisedThunks :: GraphInfo -> Bwd Frame -> [(BratThunk, [Value])] -> Bwd [Value] -> Task +runVectorisedThunks gi fz [] outs = run gi fz (Finished $ transposeRows2V $ outs <>> []) + where + -- outs accumulates a [Value] from each thunk, being a row. + -- assemble corresponding elements from each row into a VecV, + -- being that element of the output row of the vectorised thunk. + transposeRows2V :: [[Value]] -> [Value] + transposeRows2V rows = let rows' = map uncons rows + in if all isNothing rows' + then [] + else let (hds, tls) = unzip (map fromJust rows') in (VecV hds) : (transposeRows2V tls) +runVectorisedThunks gi fz ((th, inputs):ths) outs = + runThunk gi (fz :< VectorisedFuncs ths outs) th inputs + run :: GraphInfo -> Bwd Frame -> Task -> Task --run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined @@ -173,6 +189,18 @@ run gi (fz :< DoSplices hugr nid rest) (Use v) = hugr' = execState (HG.splice_prepend nid sub_hugr) hugr in evalSplices gi fz hugr' rest run gi (fz :< CallWith inputs) (Use (ThunkV th)) = runThunk gi (B0 :< ReturnTo fz) th inputs +run gi (fz :< CallWith inputs) (Use (VecThunkV ths)) = + runVectorisedThunks gi fz (fromJust $ zipSameLength ths $ transposeV2Rows inputs) B0 + where + -- inputs to the vectorised thunk are a row of vectors; + -- we run thunk#1 on the row formed from element#1 of each vector, and so on. + transposeV2Rows :: [Value] -> [[Value]] + transposeV2Rows vs + | all isEmptyVecV vs = [] + | otherwise = let (hds, tls) = unzip $ map (\(VecV (hd:tl)) -> (hd, VecV tl)) vs in hds : (transposeV2Rows tls) + isEmptyVecV :: Value -> Bool + isEmptyVecV (VecV []) = True + isEmptyVecV _ = False ---- Finished (list of values) run gi (fz :< AwaitNodeInputs req@(Ex name _)) (Finished inputs) = @@ -193,6 +221,10 @@ run gi (fz :< Alternatives ((TestMatchData _ ms, box):cs) ins) TryNextMatch = let vals = [miniEval gi env src | (NamedPort src _, _) <- matchOutputs] in run gi (fz :< CallWith vals) (EvalPort $ Ex box 0) +-- Next element of VectorisedFuncs +run gi (fz :< VectorisedFuncs th_inps outs) (Finished vals) = + runVectorisedThunks gi fz th_inps (outs :< vals) + run gi (fz :< BratValues _) t = run gi fz t run _ B0 t = t run gi fz t = run gi fz (Suspend [] t) diff --git a/brat/examples/batcher-merge-sort.brat b/brat/examples/batcher-merge-sort.brat index e72bd5f0..6c17067a 100644 --- a/brat/examples/batcher-merge-sort.brat +++ b/brat/examples/batcher-merge-sort.brat @@ -35,6 +35,6 @@ fixOffBy1(n, lo ,- (mid0 =%= mid1) -, hi) = let mid0', mid1' = (full(n) of cas)(mid0, mid1) in lo ,- (mid0' =%= mid1') -, hi ---!exec-xfail [[2,3,4,5,6,7,11,12]] +--!exec [[2,3,4,5,6,7,11,12]] test_merge :: Vec(Nat, 8) test_merge = merge(2, [2,5,7,11], [3, 4, 6, 12]) \ No newline at end of file From 237b94e03251559363ab5f584f978ef82bd9dc19 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 17:20:42 +0100 Subject: [PATCH 134/149] More vectorise tests --- brat/examples/vectorise.brat | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/brat/examples/vectorise.brat b/brat/examples/vectorise.brat index 2d8be07e..5812610f 100644 --- a/brat/examples/vectorise.brat +++ b/brat/examples/vectorise.brat @@ -15,6 +15,10 @@ zip(X, Y, n, xs, ys) = xs, ys |> (n of ({[_,_]} :: { X, Y -> [X,Y] })) +--!exec [[["yes",True],["no",False],["true",True],["false",False]]] +test_zip :: Vec([String, Bool], 4) +test_zip = zip(!, !, !, ["yes","no","true","false"], [true,false,true,false]) + mkPair(X :: *, Y :: *) -> { X, Y -> [X, Y] } mkPair(_, _) = { x, y => [x,y] } @@ -54,3 +58,14 @@ juxt = 42 of 1, 42 of true notTooGreedy(Vec(Nat, 42)) -> Vec(Nat, 42), Vec(Nat, 42) notTooGreedy(xs) = 42 of 0, xs + +addN(Nat) -> { Nat -> Nat } +addN(n) = { x => x + n } + +adders(n :: #) -> Vec({ Nat -> Nat }, n) +adders(0) = [] +adders(succ(n)) = adders(n) -, addN(succ(n)) + +--!exec [[1,2,3,4,5]] +test_adders :: Vec(Nat, 5) +test_adders = adders(5)(5 of 0) From 4caa9dd98aa77790876e178c84b52dd901b396bf Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 17:52:42 +0100 Subject: [PATCH 135/149] more batcher tests --- brat/examples/batcher-merge-sort.brat | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/brat/examples/batcher-merge-sort.brat b/brat/examples/batcher-merge-sort.brat index 6c17067a..35385275 100644 --- a/brat/examples/batcher-merge-sort.brat +++ b/brat/examples/batcher-merge-sort.brat @@ -35,6 +35,15 @@ fixOffBy1(n, lo ,- (mid0 =%= mid1) -, hi) = let mid0', mid1' = (full(n) of cas)(mid0, mid1) in lo ,- (mid0' =%= mid1') -, hi ---!exec [[2,3,4,5,6,7,11,12]] -test_merge :: Vec(Nat, 8) -test_merge = merge(2, [2,5,7,11], [3, 4, 6, 12]) \ No newline at end of file + +--!exec [[1,2,3,4]] +test_fix1 :: Vec(Nat, 4) +test_fix1 = fixOffBy1(1, [1,3,2,4]) + +--!exec [[2,3,4,5,6,7,8,9,10,11,12,15,16,16,18,19]] +test_merge :: Vec(Nat, 16) +test_merge = merge(3, [2,5,7,8,9,15,16,19], [3, 4, 6, 10, 11, 12, 16, 18]) + +--!exec [[1,5,5,7,9,11,13,15]] +test_sort :: Vec(Nat, 8) +test_sort =sort(3, [13,5,11,5,9,15,1,7]) From fdb7aa1dcc89e3a1b7c65e715b19b7fab5318d8f Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 18:12:55 +0100 Subject: [PATCH 136/149] refactor: rm runThunk --- brat/Brat/Machine.hs | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index deb64931..5515cbaf 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -128,23 +128,16 @@ runVectorisedThunks gi fz [] outs = run gi fz (Finished $ transposeRows2V $ outs -- assemble corresponding elements from each row into a VecV, -- being that element of the output row of the vectorised thunk. transposeRows2V :: [[Value]] -> [Value] - transposeRows2V rows = let rows' = map uncons rows + transposeRows2V rows = let rows' = map uncons rows in if all isNothing rows' then [] else let (hds, tls) = unzip (map fromJust rows') in (VecV hds) : (transposeRows2V tls) runVectorisedThunks gi fz ((th, inputs):ths) outs = - runThunk gi (fz :< VectorisedFuncs ths outs) th inputs + run gi (fz :< VectorisedFuncs ths outs :< CallWith inputs) (Use $ ThunkV th) run :: GraphInfo -> Bwd Frame -> Task -> Task --run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined -runThunk :: GraphInfo -> Bwd Frame -> BratThunk -> [Value] -> Task -runThunk gi fz (BratClosure env src tgt) inputs = - let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] - in evalNodeInputs gi (fz :< (BratValues env_with_args)) tgt -runThunk (g,st,ns,cs) fz (BratPrim ext op _cty) inputs - | (hugrNS,newRoot) <- split "hugr" ns, Just outs <- runPrim hugrNS (ext,op) inputs = run (g,st,newRoot,cs) fz (Finished outs) - -- Tasks that push new frames onto the stack to do things run gi fz (EvalPort p@(Ex name _)) = case lookupOutport fz p of Just v -> run gi fz (Use v) @@ -188,7 +181,12 @@ run gi (fz :< DoSplices hugr nid rest) (Use v) = let (KernelV sub_hugr) = v hugr' = execState (HG.splice_prepend nid sub_hugr) hugr in evalSplices gi fz hugr' rest -run gi (fz :< CallWith inputs) (Use (ThunkV th)) = runThunk gi (B0 :< ReturnTo fz) th inputs +run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = + let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] + in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt +run (g,st,ns,cs) (fz :< CallWith inputs) (Use (ThunkV (BratPrim ext op _cty))) + | (hugrNS,newRoot) <- split "hugr" ns, Just outs <- runPrim hugrNS (ext,op) inputs = run (g,st,newRoot,cs) fz (Finished outs) + run gi (fz :< CallWith inputs) (Use (VecThunkV ths)) = runVectorisedThunks gi fz (fromJust $ zipSameLength ths $ transposeV2Rows inputs) B0 where From 1952ed7007e8b688499ae9124b9d14d05d1a337f Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 18:16:03 +0100 Subject: [PATCH 137/149] vector of Value not BratThunk, hopefully handles >1D --- brat/Brat/Machine.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 5515cbaf..6886a517 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -57,7 +57,7 @@ data Frame where PerformMatchTests :: [(Src, PrimTest (BinderType Brat))] -> [(Src, BinderType Brat)] -> Name -> Frame DoSplices :: HG.HugrGraph HG.NodeId -> HG.NodeId -> [(HG.NodeId, OutPort)] -> Frame -- Remaining thunks with their inputs, and rows output by prior thunks - VectorisedFuncs :: [(BratThunk, [Value])] -> Bwd [Value] -> Frame + VectorisedFuncs :: [(Value, [Value])] -> Bwd [Value] -> Frame divider = replicate 78 '-' @@ -121,7 +121,7 @@ evalSplices gi fz hugr [] = run gi fz (Finished [KernelV hugr]) evalSplices gi fz hugr ((nid, outport):rest) = run gi (fz :< DoSplices hugr nid rest) (EvalPort outport) -runVectorisedThunks :: GraphInfo -> Bwd Frame -> [(BratThunk, [Value])] -> Bwd [Value] -> Task +runVectorisedThunks :: GraphInfo -> Bwd Frame -> [(Value, [Value])] -> Bwd [Value] -> Task runVectorisedThunks gi fz [] outs = run gi fz (Finished $ transposeRows2V $ outs <>> []) where -- outs accumulates a [Value] from each thunk, being a row. @@ -133,7 +133,7 @@ runVectorisedThunks gi fz [] outs = run gi fz (Finished $ transposeRows2V $ outs then [] else let (hds, tls) = unzip (map fromJust rows') in (VecV hds) : (transposeRows2V tls) runVectorisedThunks gi fz ((th, inputs):ths) outs = - run gi (fz :< VectorisedFuncs ths outs :< CallWith inputs) (Use $ ThunkV th) + run gi (fz :< VectorisedFuncs ths outs :< CallWith inputs) (Use th) run :: GraphInfo -> Bwd Frame -> Task -> Task --run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined @@ -167,7 +167,7 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of (BratNode MapFun _ _) -> case ins of -- We have a vector of functions [IntV len, VecV funs] -> if len == length funs - then run gi fz (Finished [VecThunkV $ map (\(ThunkV t) -> t) funs]) + then run gi fz (Finished [VecThunkV funs]) else error $ "MapFun length argument " ++ show len ++ " doesn't match length of function vector " ++ show (length funs) nw -> run gi fz (StuckOnNode n nw) @@ -384,7 +384,8 @@ data Value = | ThunkV BratThunk | KernelV (HG.HugrGraph HG.NodeId) | DummyV - | VecThunkV [BratThunk] -- Vectorised thunk, result of MapFun + | VecThunkV [Value] -- Vectorised thunk, result of MapFun; + -- elements are ThunkV (for 1D) or VecThunkV (for higher dimensions) data BratThunk = -- this might want to be [EvalEnv] or something like that From 3e645262363323e529e590a7ac5dfeeb607331c4 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 18:26:10 +0100 Subject: [PATCH 138/149] Machine: Dig for appropriate vectorised function --- brat/Brat/Machine.hs | 25 +++++++++++++++++++++---- brat/examples/vectorise.brat | 9 +++++++++ 2 files changed, 30 insertions(+), 4 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 6886a517..233656c6 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -57,7 +57,7 @@ data Frame where PerformMatchTests :: [(Src, PrimTest (BinderType Brat))] -> [(Src, BinderType Brat)] -> Name -> Frame DoSplices :: HG.HugrGraph HG.NodeId -> HG.NodeId -> [(HG.NodeId, OutPort)] -> Frame -- Remaining thunks with their inputs, and rows output by prior thunks - VectorisedFuncs :: [(Value, [Value])] -> Bwd [Value] -> Frame + VectorisedFuncs :: [({- thunk: -}Value, [Value])] -> Bwd [Value] -> Frame divider = replicate 78 '-' @@ -166,10 +166,27 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of [IntV n, elem] -> run gi fz (Finished [(VecV (replicate n elem))]) (BratNode MapFun _ _) -> case ins of -- We have a vector of functions - [IntV len, VecV funs] -> if len == length funs - then run gi fz (Finished [VecThunkV funs]) - else error $ "MapFun length argument " ++ show len ++ " doesn't match length of function vector " ++ show (length funs) + [IntV len, VecV funs] -> run gi fz (Finished [dig len funs]) nw -> run gi fz (StuckOnNode n nw) + where + -- Assumes uniform type + dig :: Int -> [Value] -> Value + dig n vals + | Just vecs <- getVecs vals = VecV ((\(VecV vs) -> dig n vs) <$> vecs) + | Just ths <- getThunks vals + , n == length vals = VecThunkV ths + where + getVecs :: [Value] -> Maybe [Value] + getVecs [] = Just [] + getVecs (VecV x:xs) = ((VecV x):) <$> getVecs xs + getVecs _ = Nothing + + getThunks :: [Value] -> Maybe [Value] + getThunks [] = Just [] + getThunks (ThunkV th:ths) = (ThunkV th:) <$> getThunks ths + getThunks (VecThunkV ths:thss) = (VecThunkV ths:) <$> getThunks thss + getThunks _ = Nothing + -- Tasks that unwind the stack looking for what to do with the result ----Suspend diff --git a/brat/examples/vectorise.brat b/brat/examples/vectorise.brat index 5812610f..efa421aa 100644 --- a/brat/examples/vectorise.brat +++ b/brat/examples/vectorise.brat @@ -34,6 +34,15 @@ rank2(X :: *, Y :: *, Z :: *, --rank2(_, _, _, n, m, fstArgs, sndArgs, f) = fstArgs, sndArgs |> m of n of f rank2(_, _, _, n, m, fstArgs, sndArgs, f) = (m of n of f)(fstArgs, sndArgs) +leq(Nat, Nat) -> Bool +leq(0, _) = true +leq(_, 0) = false +leq(succ(l), succ(n)) = leq(l, n) + +--!exec [[[True,False,True],[True,False,True]]] +test_rank2 :: Vec(Vec(Bool, 3), 2) +test_rank2 = rank2(!, !, !, !, !, [[1, 2, 3], [4, 5, 6]], [[2, 1, 3], [5, 4, 6]], leq) + f(X :: *, n :: #, Vec(X, n)) -> Vec(X, 2 * n) f(X, 0, []) = [] f(X, succ(n), x ,- xs) = x ,- x ,- f(X, n, xs) From 7d3135e1de1c99fa2e66431fc0a53831bdb2354f Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 22 Apr 2026 18:29:12 +0100 Subject: [PATCH 139/149] StringV --- brat/Brat/Machine.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 233656c6..16fdb47a 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -340,6 +340,7 @@ captureEnv (fz :< _) keys = captureEnv fz keys evalSimpleTerm :: SimpleTerm -> Value evalSimpleTerm (Num x) = IntV x evalSimpleTerm (Float x) = FloatV x +evalSimpleTerm (Text s) = StringV s evalSimpleTerm t = error ("todo " ++ show t) evalArith :: ArithOp -> [Value] -> Value @@ -403,6 +404,7 @@ data Value = | DummyV | VecThunkV [Value] -- Vectorised thunk, result of MapFun; -- elements are ThunkV (for 1D) or VecThunkV (for higher dimensions) + | StringV String data BratThunk = -- this might want to be [EvalEnv] or something like that @@ -418,5 +420,6 @@ instance Show Value where show (KernelV k) = "Kernel (" ++ show k ++ ")" show (VecThunkV ths) = "" show DummyV = "Dummy" + show (StringV str) = show str type EvalEnv = M.Map OutPort Value From a878b75e0edd8f1f296fe58754ec6e8acf07b6c9 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Wed, 22 Apr 2026 22:41:17 +0100 Subject: [PATCH 140/149] Remove VecThunkV, add BratThunk::VectorisedThunks --- brat/Brat/Machine.hs | 51 ++++++++++++++++++++++---------------------- 1 file changed, 26 insertions(+), 25 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 6886a517..6f001300 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -57,7 +57,7 @@ data Frame where PerformMatchTests :: [(Src, PrimTest (BinderType Brat))] -> [(Src, BinderType Brat)] -> Name -> Frame DoSplices :: HG.HugrGraph HG.NodeId -> HG.NodeId -> [(HG.NodeId, OutPort)] -> Frame -- Remaining thunks with their inputs, and rows output by prior thunks - VectorisedFuncs :: [(Value, [Value])] -> Bwd [Value] -> Frame + VectorisedFuncs :: [(BratThunk, [Value])] -> Bwd [Value] -> Frame divider = replicate 78 '-' @@ -121,7 +121,7 @@ evalSplices gi fz hugr [] = run gi fz (Finished [KernelV hugr]) evalSplices gi fz hugr ((nid, outport):rest) = run gi (fz :< DoSplices hugr nid rest) (EvalPort outport) -runVectorisedThunks :: GraphInfo -> Bwd Frame -> [(Value, [Value])] -> Bwd [Value] -> Task +runVectorisedThunks :: GraphInfo -> Bwd Frame -> [(BratThunk, [Value])] -> Bwd [Value] -> Task runVectorisedThunks gi fz [] outs = run gi fz (Finished $ transposeRows2V $ outs <>> []) where -- outs accumulates a [Value] from each thunk, being a row. @@ -133,11 +133,30 @@ runVectorisedThunks gi fz [] outs = run gi fz (Finished $ transposeRows2V $ outs then [] else let (hds, tls) = unzip (map fromJust rows') in (VecV hds) : (transposeRows2V tls) runVectorisedThunks gi fz ((th, inputs):ths) outs = - run gi (fz :< VectorisedFuncs ths outs :< CallWith inputs) (Use th) + runThunk gi (fz :< VectorisedFuncs ths outs) th inputs run :: GraphInfo -> Bwd Frame -> Task -> Task --run g fz t | trace ("RUN: " ++ show fz ++ "\n" ++ show t) False = undefined +runThunk :: GraphInfo -> Bwd Frame -> BratThunk -> [Value] -> Task +runThunk gi fz (BratClosure env src tgt) inputs = + let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] + in evalNodeInputs gi (fz :< (BratValues env_with_args)) tgt +runThunk (g,st,ns,cs) fz (BratPrim ext op _cty) inputs + | (hugrNS,newRoot) <- split "hugr" ns, Just outs <- runPrim hugrNS (ext,op) inputs = run (g,st,newRoot,cs) fz (Finished outs) +runThunk gi fz (VectorisedThunks ths) inputs = + runVectorisedThunks gi fz (fromJust $ zipSameLength ths $ transposeV2Rows inputs) B0 + where + -- inputs to the vectorised thunk are a row of vectors; + -- we run thunk#1 on the row formed from element#1 of each vector, and so on. + transposeV2Rows :: [Value] -> [[Value]] + transposeV2Rows vs + | all isEmptyVecV vs = [] + | otherwise = let (hds, tls) = unzip $ map (\(VecV (hd:tl)) -> (hd, VecV tl)) vs in hds : (transposeV2Rows tls) + isEmptyVecV :: Value -> Bool + isEmptyVecV (VecV []) = True + isEmptyVecV _ = False + -- Tasks that push new frames onto the stack to do things run gi fz (EvalPort p@(Ex name _)) = case lookupOutport fz p of Just v -> run gi fz (Use v) @@ -167,7 +186,7 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of (BratNode MapFun _ _) -> case ins of -- We have a vector of functions [IntV len, VecV funs] -> if len == length funs - then run gi fz (Finished [VecThunkV funs]) + then run gi fz (Finished [ThunkV $ VectorisedThunks $ map (\(ThunkV t) -> t) funs]) else error $ "MapFun length argument " ++ show len ++ " doesn't match length of function vector " ++ show (length funs) nw -> run gi fz (StuckOnNode n nw) @@ -181,24 +200,7 @@ run gi (fz :< DoSplices hugr nid rest) (Use v) = let (KernelV sub_hugr) = v hugr' = execState (HG.splice_prepend nid sub_hugr) hugr in evalSplices gi fz hugr' rest -run gi (fz :< CallWith inputs) (Use (ThunkV (BratClosure env src tgt))) = - let env_with_args = foldr (uncurry M.insert) env [(Ex src off, val) | (off, val) <- zip [0..] inputs] - in evalNodeInputs gi (B0 :< ReturnTo fz :< (BratValues env_with_args)) tgt -run (g,st,ns,cs) (fz :< CallWith inputs) (Use (ThunkV (BratPrim ext op _cty))) - | (hugrNS,newRoot) <- split "hugr" ns, Just outs <- runPrim hugrNS (ext,op) inputs = run (g,st,newRoot,cs) fz (Finished outs) - -run gi (fz :< CallWith inputs) (Use (VecThunkV ths)) = - runVectorisedThunks gi fz (fromJust $ zipSameLength ths $ transposeV2Rows inputs) B0 - where - -- inputs to the vectorised thunk are a row of vectors; - -- we run thunk#1 on the row formed from element#1 of each vector, and so on. - transposeV2Rows :: [Value] -> [[Value]] - transposeV2Rows vs - | all isEmptyVecV vs = [] - | otherwise = let (hds, tls) = unzip $ map (\(VecV (hd:tl)) -> (hd, VecV tl)) vs in hds : (transposeV2Rows tls) - isEmptyVecV :: Value -> Bool - isEmptyVecV (VecV []) = True - isEmptyVecV _ = False +run gi (fz :< CallWith inputs) (Use (ThunkV th)) = runThunk gi (B0 :< ReturnTo fz) th inputs ---- Finished (list of values) run gi (fz :< AwaitNodeInputs req@(Ex name _)) (Finished inputs) = @@ -384,22 +386,21 @@ data Value = | ThunkV BratThunk | KernelV (HG.HugrGraph HG.NodeId) | DummyV - | VecThunkV [Value] -- Vectorised thunk, result of MapFun; - -- elements are ThunkV (for 1D) or VecThunkV (for higher dimensions) data BratThunk = -- this might want to be [EvalEnv] or something like that BratClosure EvalEnv Name Name -- Captured environment, src node, tgt node | BratPrim String String (CTy Brat Z) + | VectorisedThunks [BratThunk] instance Show Value where show (IntV x) = show x show (FloatV x) = show x show (BoolV x) = show x show (VecV xs) = show xs + show (ThunkV (VectorisedThunks ths)) = "" show (ThunkV _) = "" show (KernelV k) = "Kernel (" ++ show k ++ ")" - show (VecThunkV ths) = "" show DummyV = "Dummy" type EvalEnv = M.Map OutPort Value From e6d10ea10c8748f9bb1af12935e3fe36a67932b0 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 23 Apr 2026 08:46:50 +0100 Subject: [PATCH 141/149] dig inside getVecs --- brat/Brat/Machine.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 42532552..c0253f77 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -191,13 +191,13 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of -- Assumes uniform type dig :: Int -> [Value] -> Value dig n vals - | Just vecs <- getVecs vals = VecV ((\(VecV vs) -> dig n vs) <$> vecs) + | Just vecs <- getVecs vals = VecV vecs | Just ths <- getThunks vals , n == length vals = ThunkV (VectorisedThunks ths) where getVecs :: [Value] -> Maybe [Value] getVecs [] = Just [] - getVecs (VecV x:xs) = ((VecV x):) <$> getVecs xs + getVecs (VecV x:xs) = ((dig n x):) <$> getVecs xs getVecs _ = Nothing getThunks :: [Value] -> Maybe [BratThunk] From aafb9bb6b3296d01e2eddbbeff2398a707fcf4b6 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 23 Apr 2026 08:50:09 +0100 Subject: [PATCH 142/149] use MapM in Maybe monad for getVecs+getThunks --- brat/Brat/Machine.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index c0253f77..c28ea8a9 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -191,18 +191,16 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of -- Assumes uniform type dig :: Int -> [Value] -> Value dig n vals - | Just vecs <- getVecs vals = VecV vecs - | Just ths <- getThunks vals + | Just vecs <- mapM getVecs vals = VecV vecs + | Just ths <- mapM getThunks vals , n == length vals = ThunkV (VectorisedThunks ths) where - getVecs :: [Value] -> Maybe [Value] - getVecs [] = Just [] - getVecs (VecV x:xs) = ((dig n x):) <$> getVecs xs + getVecs :: Value -> Maybe Value + getVecs (VecV x) = Just (dig n x) getVecs _ = Nothing - getThunks :: [Value] -> Maybe [BratThunk] - getThunks [] = Just [] - getThunks (ThunkV th:ths) = (th:) <$> getThunks ths + getThunks :: Value -> Maybe BratThunk + getThunks (ThunkV th) = Just th getThunks _ = Nothing From 70870c68ec153d1aee5c4fad54e6dd20db07ace2 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Thu, 23 Apr 2026 09:03:20 +0100 Subject: [PATCH 143/149] comment --- brat/Brat/Machine.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index c28ea8a9..5a404e99 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -184,11 +184,15 @@ run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of (BratNode Replicate _ _) -> case ins of [IntV n, elem] -> run gi fz (Finished [(VecV (replicate n elem))]) (BratNode MapFun _ _) -> case ins of - -- We have a vector of functions + -- We have a vector (or vec of vecs, n-dimensions) of functions [IntV len, VecV funs] -> run gi fz (Finished [dig len funs]) nw -> run gi fz (StuckOnNode n nw) where - -- Assumes uniform type + -- Assuming a tree of VecV's whose leaf values are ThunkV's, + -- Convert the bottom level of VecV's to VectorisedFuncs. + -- We assume the tree is of uniform height (and arity at each *level*, + -- perhaps varying between levels), this should be guaranteed by the checker. + -- (TODO: consider encoding the expected levels/arities in the MapFun?) dig :: Int -> [Value] -> Value dig n vals | Just vecs <- mapM getVecs vals = VecV vecs From faf03c4cc6944532588142c457fe7dfe1f0c1242 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 24 Apr 2026 08:50:23 +0100 Subject: [PATCH 144/149] cons.brat whitespace --- brat/examples/cons.brat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/examples/cons.brat b/brat/examples/cons.brat index f565abb6..a9a10289 100644 --- a/brat/examples/cons.brat +++ b/brat/examples/cons.brat @@ -18,7 +18,7 @@ goodBinding = let x, y = twoThings in x, y -- Functions can be applied directly to things that -- represent the right number of values three :: Int -three = add(twoThings) +three = add(twoThings) -- Is equivalent to: --!exec [3] From b12abada96503aad6d7979d7938e57369d1b69eb Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 24 Apr 2026 08:59:53 +0100 Subject: [PATCH 145/149] reinstate hea.brat --- brat/examples/hea.brat | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 brat/examples/hea.brat diff --git a/brat/examples/hea.brat b/brat/examples/hea.brat new file mode 100644 index 00000000..36768518 --- /dev/null +++ b/brat/examples/hea.brat @@ -0,0 +1,40 @@ +--!xfail-checking +-- Playing with representing a hardware-efficient ansatz + +-- Expectation: +-- - this file parses and typechecks + +-- Reality: +-- - kernel compilation doesn't find `numNodes` or `Operator` + +open import lib.kernel + +type Real = Nat -- Temporary hack + +type Operator = [[Nat, Nat],Real] + +type Pauli = Vec(Nat, 0) + +edges :: Vec(Operator, 1) +edges = ?e + +numNodes :: Nat +numNodes = ?nn + +numEdges :: Nat +numEdges = ?ne + +apply_operators :: { Vec(Money, numNodes) + , Vec(Operator, numEdges) + -o Vec(Qubit, numNodes) + } +apply_operators = ?help + +-- map :: (f :: {A -> B}), (xs :: Vec A n) -> (ys :: Vec B n) +-- map = f, xs => ?ys + +hea(rotations :: Vec (Operator, numEdges) + ,meas :: Vec (Pauli ,numNodes) + ,(cash :: Vec (Money ,numNodes))) + -> (cash :: Vec (Money ,numNodes)), (result :: Vec(Bool, numNodes)) +hea = rots, meas => ?j -- apply-operators; meas(cash); xs => map(measure,xs); transpose From ffd06137aeb326b264b7df5ce617a5c1040d8d46 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 24 Apr 2026 12:26:07 +0100 Subject: [PATCH 146/149] lookupOutport looks only in local BratValues --- brat/Brat/Machine.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 5a404e99..f675baa5 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -94,8 +94,10 @@ data Task where lookupOutport :: Bwd Frame -> OutPort -> Maybe Value lookupOutport B0 _ = Nothing --- TODO: Highly suspect that we keep looking beyond the most local cache -lookupOutport (_ :< BratValues env) p | Just v <- M.lookup p env = Just v +-- TODO: Might we need to look beyond the most local cache? +-- Believe "CaptureSets" are computed to ensure we don't need to. +lookupOutport (_ :< BratValues env) p = M.lookup p env +--lookupOutport (_ :< BratValues env) p | Just v <- M.lookup p env = Just v lookupOutport (fz :< _) p = lookupOutport fz p evalPorts :: GraphInfo -> Bwd Frame -> Bwd Value -> [OutPort] -> Task From 8f56da299d4a3e08da04ea059046415536e905f6 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 24 Apr 2026 12:42:34 +0100 Subject: [PATCH 147/149] comments --- brat/Brat/Machine.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index f675baa5..7bba3610 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -42,13 +42,14 @@ runInterpreter libDirs file runFunc = do data Frame where BratValues :: EvalEnv -> Frame - -- Optionally "what to do when all ports evaled" - Node weight, name+offset requested - -- then state of evaluating inputs: (values computed, ports whose values still needed) + -- In process of evaluating a list of OutPorts: (values computed, ports still needed) + -- (excluding the one that's in process of being evaluated) EvalPorts :: Bwd Value -> [OutPort] -> Frame -- We're waiting for a task to deliver us all of the inputs for this node, - -- then we can deliver the outputs. + -- goal is to deliver the single requested OutPort (after evaluating the node) AwaitNodeInputs :: OutPort -> Frame - -- Also responsible for caching all node outputs + -- Waiting for a task to deliver us all of the outputs for a node, + -- goal is to deliver the single requested OutPort. SelectFromNodeOutputs :: OutPort -> Frame -- have arguments to function, waiting for the function: CallWith :: [Value] -> Frame @@ -82,12 +83,19 @@ showFrames :: Bwd Frame -> [String] showFrames = foldMap (\f -> divider : showFrame f) data Task where + -- Evaluates a port (or retrieves value from cache) EvalPort :: OutPort -> Task Suspend :: [Frame] -> Task -> Task + -- Evaluate a node given its inputs (graph edges, excluding e.g. func to Eval) EvalNode :: Name -> [Value] -> Task - Use :: Value -> Task -- searches for EvalPorts or DoSplices - Finished :: [Value] -> Task -- searches for SelectFromNodeOutputs, or final result + -- A single Outport value is ready; searches for EvalPorts or DoSplices to use it. + Use :: Value -> Task + -- Finished computing a list of values (all outputs of one node); + -- searches for SelectFromNodeOutputs to use one, or is final result (of runInterpreter or ReturnTo). + Finished :: [Value] -> Task + -- Try the next clause in an Alternatives TryNextMatch :: Task + -- No clause in an Alternatives matched NoMatch :: Task StuckOnNode :: Name -> Node -> Task deriving Show From 1b61797d132cd4f0059eef27a320071247626d8b Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 24 Apr 2026 13:16:24 +0100 Subject: [PATCH 148/149] EvalPort -> evalPort --- brat/Brat/Machine.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 7bba3610..6259af40 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -83,8 +83,6 @@ showFrames :: Bwd Frame -> [String] showFrames = foldMap (\f -> divider : showFrame f) data Task where - -- Evaluates a port (or retrieves value from cache) - EvalPort :: OutPort -> Task Suspend :: [Frame] -> Task -> Task -- Evaluate a node given its inputs (graph edges, excluding e.g. func to Eval) EvalNode :: Name -> [Value] -> Task @@ -111,9 +109,15 @@ lookupOutport (fz :< _) p = lookupOutport fz p evalPorts :: GraphInfo -> Bwd Frame -> Bwd Value -> [OutPort] -> Task -- EvalPorts is "missing" one input (between valz and ports), i.e. the one that's the current Task -- (whereas evalPorts has them all) -evalPorts g fz valz (p:ps) = run g (fz :< EvalPorts valz ps) (EvalPort p) +evalPorts g fz valz (p:ps) = evalPort g (fz :< EvalPorts valz ps) p evalPorts g fz valz [] = run g fz (Finished (valz <>> [])) +-- Evaluates a port (or retrieves value from cache) +evalPort :: GraphInfo -> Bwd Frame -> OutPort -> Task +evalPort gi fz p@(Ex name _) = case lookupOutport fz p of + Just v -> run gi fz (Use v) + Nothing -> evalNodeInputs gi (fz :< AwaitNodeInputs p) name + getNodeInputs :: GraphInfo -> Name -> [OutPort] getNodeInputs (g, _, _, _) name = M.elems (M.fromList [(tgtPort, src) | (src, _, In _ tgtPort) <- wiresTo name g]) @@ -129,7 +133,7 @@ updateCache (fz :< f) pvs = (updateCache fz pvs) :< f evalSplices :: GraphInfo -> Bwd Frame -> HG.HugrGraph HG.NodeId -> [(HG.NodeId, OutPort)] -> Task evalSplices gi fz hugr [] = run gi fz (Finished [KernelV hugr]) evalSplices gi fz hugr ((nid, outport):rest) = - run gi (fz :< DoSplices hugr nid rest) (EvalPort outport) + evalPort gi (fz :< DoSplices hugr nid rest) outport runVectorisedThunks :: GraphInfo -> Bwd Frame -> [(BratThunk, [Value])] -> Bwd [Value] -> Task runVectorisedThunks gi fz [] outs = run gi fz (Finished $ transposeRows2V $ outs <>> []) @@ -168,15 +172,12 @@ runThunk gi fz (VectorisedThunks ths) inputs = isEmptyVecV _ = False -- Tasks that push new frames onto the stack to do things -run gi fz (EvalPort p@(Ex name _)) = case lookupOutport fz p of - Just v -> run gi fz (Use v) - Nothing -> evalNodeInputs gi (fz :< AwaitNodeInputs p) name run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of --nw | trace ("EVALNODE " ++ show nw) False -> undefined (BratNode (Const st) _ _) -> run gi fz (Finished [evalSimpleTerm st]) (BratNode (ArithNode op) _ _) -> run gi fz (Finished [evalArith op ins]) (BratNode Id _ _) -> run gi fz (Finished ins) - (BratNode (Eval func) _ _) -> run gi (fz :< CallWith ins) (EvalPort func) + (BratNode (Eval func) _ _) -> evalPort gi (fz :< CallWith ins) func (BratNode (Box _ _) [] [(_, VFun Kerny _)]) -> let (sub, newRoot) = split "box" root (hugr, splices) = compileKernel (sub, st, g) "box" n @@ -247,7 +248,7 @@ run gi (fz :< Alternatives ((TestMatchData _ ms, box):cs) ins) TryNextMatch = Nothing -> run gi (fz :< Alternatives cs ins) TryNextMatch Just env -> let vals = [miniEval gi env src | (NamedPort src _, _) <- matchOutputs] - in run gi (fz :< CallWith vals) (EvalPort $ Ex box 0) + in evalPort gi (fz :< CallWith vals) $ Ex box 0 -- Next element of VectorisedFuncs run gi (fz :< VectorisedFuncs th_inps outs) (Finished vals) = From ae9b2716076a0a5b97bb538345bba84433401ac6 Mon Sep 17 00:00:00 2001 From: Alan Lawrence Date: Fri, 24 Apr 2026 13:25:47 +0100 Subject: [PATCH 149/149] EvalNode -> evalNode --- brat/Brat/Machine.hs | 59 ++++++++++++++++++++++---------------------- 1 file changed, 29 insertions(+), 30 deletions(-) diff --git a/brat/Brat/Machine.hs b/brat/Brat/Machine.hs index 6259af40..45037279 100644 --- a/brat/Brat/Machine.hs +++ b/brat/Brat/Machine.hs @@ -84,8 +84,6 @@ showFrames = foldMap (\f -> divider : showFrame f) data Task where Suspend :: [Frame] -> Task -> Task - -- Evaluate a node given its inputs (graph edges, excluding e.g. func to Eval) - EvalNode :: Name -> [Value] -> Task -- A single Outport value is ready; searches for EvalPorts or DoSplices to use it. Use :: Value -> Task -- Finished computing a list of values (all outputs of one node); @@ -171,33 +169,34 @@ runThunk gi fz (VectorisedThunks ths) inputs = isEmptyVecV (VecV []) = True isEmptyVecV _ = False --- Tasks that push new frames onto the stack to do things -run gi@(g@(nodes, _), st, root, cs) fz (EvalNode n ins) = case nodes M.! n of - --nw | trace ("EVALNODE " ++ show nw) False -> undefined - (BratNode (Const st) _ _) -> run gi fz (Finished [evalSimpleTerm st]) - (BratNode (ArithNode op) _ _) -> run gi fz (Finished [evalArith op ins]) - (BratNode Id _ _) -> run gi fz (Finished ins) - (BratNode (Eval func) _ _) -> evalPort gi (fz :< CallWith ins) func - (BratNode (Box _ _) [] [(_, VFun Kerny _)]) -> - let (sub, newRoot) = split "box" root - (hugr, splices) = compileKernel (sub, st, g) "box" n - in evalSplices (g, st, newRoot, cs) fz hugr splices - (BratNode (Box src tgt) _ _) -> - let captureSet = fromMaybe M.empty (M.lookup n cs) - capturedSrcs = S.fromList [src | (NamedPort src _name, _ty) <- concat (M.elems captureSet)] - in run gi fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) - (BratNode (PatternMatch (c:|cs)) _ _) -> run gi (fz :< Alternatives (c:cs) ins) TryNextMatch - (BratNode (Constructor c) _ _) -> run gi fz (Finished [evalConstructor c ins]) - (BratNode (Dummy _) _ _) -> run gi fz (Finished [DummyV]) - (BratNode (Prim (ext, op)) [] [(_, VFun Braty cty)]) -> run gi fz (Finished [ThunkV (BratPrim ext op cty)]) - (BratNode (Selector stor) _ _) -> case (stor, ins) of - (PrefixName [] "cons", [VecV (x:xs)]) -> run gi fz (Finished [x, VecV xs]) - (BratNode Replicate _ _) -> case ins of - [IntV n, elem] -> run gi fz (Finished [(VecV (replicate n elem))]) - (BratNode MapFun _ _) -> case ins of - -- We have a vector (or vec of vecs, n-dimensions) of functions - [IntV len, VecV funs] -> run gi fz (Finished [dig len funs]) - nw -> run gi fz (StuckOnNode n nw) +-- Evaluate a node given its inputs (graph edges, excluding e.g. func to Eval) +evalNode :: GraphInfo -> Bwd Frame -> Name -> [Value] -> Task +evalNode gi@(g@(nodes, _), st, root, cs) fz n ins = case nodes M.! n of + --nw | trace ("EVALNODE " ++ show nw) False -> undefined + (BratNode (Const st) _ _) -> run gi fz (Finished [evalSimpleTerm st]) + (BratNode (ArithNode op) _ _) -> run gi fz (Finished [evalArith op ins]) + (BratNode Id _ _) -> run gi fz (Finished ins) + (BratNode (Eval func) _ _) -> evalPort gi (fz :< CallWith ins) func + (BratNode (Box _ _) [] [(_, VFun Kerny _)]) -> + let (sub, newRoot) = split "box" root + (hugr, splices) = compileKernel (sub, st, g) "box" n + in evalSplices (g, st, newRoot, cs) fz hugr splices + (BratNode (Box src tgt) _ _) -> + let captureSet = fromMaybe M.empty (M.lookup n cs) + capturedSrcs = S.fromList [src | (NamedPort src _name, _ty) <- concat (M.elems captureSet)] + in run gi fz (Finished [ThunkV $ BratClosure (captureEnv fz capturedSrcs) src tgt]) + (BratNode (PatternMatch (c:|cs)) _ _) -> run gi (fz :< Alternatives (c:cs) ins) TryNextMatch + (BratNode (Constructor c) _ _) -> run gi fz (Finished [evalConstructor c ins]) + (BratNode (Dummy _) _ _) -> run gi fz (Finished [DummyV]) + (BratNode (Prim (ext, op)) [] [(_, VFun Braty cty)]) -> run gi fz (Finished [ThunkV (BratPrim ext op cty)]) + (BratNode (Selector stor) _ _) -> case (stor, ins) of + (PrefixName [] "cons", [VecV (x:xs)]) -> run gi fz (Finished [x, VecV xs]) + (BratNode Replicate _ _) -> case ins of + [IntV n, elem] -> run gi fz (Finished [(VecV (replicate n elem))]) + (BratNode MapFun _ _) -> case ins of + -- We have a vector (or vec of vecs, n-dimensions) of functions + [IntV len, VecV funs] -> run gi fz (Finished [dig len funs]) + nw -> run gi fz (StuckOnNode n nw) where -- Assuming a tree of VecV's whose leaf values are ThunkV's, -- Convert the bottom level of VecV's to VectorisedFuncs. @@ -233,7 +232,7 @@ run gi (fz :< CallWith inputs) (Use (ThunkV th)) = runThunk gi (B0 :< ReturnTo f ---- Finished (list of values) run gi (fz :< AwaitNodeInputs req@(Ex name _)) (Finished inputs) = - run gi (fz :< SelectFromNodeOutputs req) (EvalNode name inputs) + evalNode gi (fz :< SelectFromNodeOutputs req) name inputs run gi (fz :< SelectFromNodeOutputs (Ex name offset)) (Finished outputs) = run gi (updateCache fz [(Ex name i, val) | (i, val) <- zip [0..] outputs]) (Use (outputs !! offset)) run gi (B0 :< ReturnTo fz) (Finished vals) = run gi fz (Finished vals)