From 73c9c37bec285e6028557735ee4c33c0a7dfc9ca Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 3 Mar 2026 13:10:07 +0000 Subject: [PATCH 1/4] Fix actions syntax for hlint --- .github/workflows/hlint.yaml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/workflows/hlint.yaml b/.github/workflows/hlint.yaml index 39de47b3..0daa766d 100644 --- a/.github/workflows/hlint.yaml +++ b/.github/workflows/hlint.yaml @@ -1,6 +1,9 @@ name: Brat CI on: - pull_request: [] + pull_request: + branches: [main] + paths: + - "**.hs" jobs: hlint: From 5f1dd4782d9e30c49ec6a8b4de012f44c5c80c55 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 3 Mar 2026 13:49:30 +0000 Subject: [PATCH 2/4] hlint fixes --- brat/Brat/Checker.hs | 6 +++--- brat/Brat/Checker/Monad.hs | 8 ++++---- brat/Brat/Checker/SolveNumbers.hs | 12 ++++++------ brat/Brat/Checker/SolvePatterns.hs | 18 ++++++++++-------- brat/Brat/Compile/Hugr.hs | 14 ++++++-------- brat/Brat/Eval.hs | 4 ++-- brat/Brat/Load.hs | 2 +- brat/Control/Monad/Freer.hs | 4 ++-- brat/Data/HugrGraph.hs | 22 +++++++++++----------- brat/test/Test/Compile/Hugr.hs | 5 ++--- brat/test/Test/Util.hs | 2 +- 11 files changed, 48 insertions(+), 49 deletions(-) diff --git a/brat/Brat/Checker.hs b/brat/Brat/Checker.hs index 6bc2643a..50a273fb 100644 --- a/brat/Brat/Checker.hs +++ b/brat/Brat/Checker.hs @@ -763,7 +763,7 @@ checkClause my fnName cty clause = modily my $ do trackM $ "[[[[[[TestMatchData\n" ++ show match ++ "\n]]]]]]" pure (sol, match, patRo :->> outRo, fmap (Some . (patEz :*) . abstractEndz patEz) <$> defs) - for defs $ \((name, kind), Some (_ :* val)) -> trackM ("Def: " ++ show ((name, kind), val)) + for_ defs $ \((name, kind), Some (_ :* val)) -> trackM ("Def: " ++ show ((name, kind), val)) -- Now actually make a box for the RHS and check it ((boxPort, _ty), _) <- let ?my = my in makeBox (clauseName ++ "_rhs") rhsCty $ \(rhsOvers, rhsUnders) -> do @@ -786,7 +786,7 @@ checkClause my fnName cty clause = modily my $ do -- would arise if we've not yet defined the outer src let vars = fst <$> sol env <- mkEnv vars rhsOvers - (localEnv (env <> defs) $ "$rhs" -! check @m (rhs clause) ((), rhsUnders)) + localEnv (env <> defs) $ "$rhs" -! check @m (rhs clause) ((), rhsUnders) let NamedPort {end=Ex rhsNode _} = boxPort pure (match, rhsNode) where @@ -1289,6 +1289,6 @@ run ve initStore ns m = do -- show multiple error locations hs@((_,fc):_) -> Left $ Err (Just fc) (RemainingNatHopes (show . fst <$> hs)) where - isNatKinded tyMap e = case tyMap M.! (InEnd e) of + isNatKinded tyMap e = case tyMap M.! InEnd e of (EndType Braty (Left Nat), _) -> True _ -> False diff --git a/brat/Brat/Checker/Monad.hs b/brat/Brat/Checker/Monad.hs index 12f15aca..4d5ade97 100644 --- a/brat/Brat/Checker/Monad.hs +++ b/brat/Brat/Checker/Monad.hs @@ -131,7 +131,7 @@ wrapper f (Yield st k) = Yield st (wrapper f . k) wrapper f (Fork d par c) = Fork d (wrapper f par) (wrapper f c) wrapper2 :: (forall a. CheckingSig a -> Maybe a) -> Checking v -> Checking v -wrapper2 f = wrapper (\s -> pure (f s)) +wrapper2 f = wrapper (pure . f) localAlias :: (QualName, Alias) -> Checking v -> Checking v localAlias (name, alias) = wrapper2 (\case @@ -142,7 +142,7 @@ localFC :: FC -> Checking v -> Checking v localFC f = wrapper (\case AskFC -> pure $ Just f (Throw e@Err{fc=Nothing}) -> req (Throw (e{fc=Just f})) >> error "Throw returned" - _ -> pure $ Nothing) + _ -> pure Nothing) localEnv :: (?my :: Modey m) => Env (EnvData m) -> Checking v -> Checking v localEnv = case ?my of @@ -167,7 +167,7 @@ captureOuterLocals n c = do where helper :: VEnv -> forall a. CheckingSig a -> Checking (Maybe a) helper avail (VLup x) | j@(Just new) <- M.lookup x avail = - (req $ AddCapture n (x,new)) >> (pure $ Just j) + req (AddCapture n (x,new)) >> pure (Just j) helper _ _ = pure Nothing wrapError :: (Error -> Error) -> Checking v -> Checking v @@ -343,7 +343,7 @@ handler (Define lbl end v k) ctx g = let st@Store{typeMap=tm, valueMap=vm} = sto InEnd inport -> case M.lookup inport (dynamicSet ctx) of Just fc -> track ("Replace " ++ show end ++ " with " ++ show newDynamics) $ M.union - (M.fromList (zip newDynamics (repeat fc))) + (M.fromList (map (, fc) newDynamics)) (M.delete inport (dynamicSet ctx)) Nothing -> dynamicSet ctx }) g diff --git a/brat/Brat/Checker/SolveNumbers.hs b/brat/Brat/Checker/SolveNumbers.hs index 8089c506..8ce2fb6b 100644 --- a/brat/Brat/Checker/SolveNumbers.hs +++ b/brat/Brat/Checker/SolveNumbers.hs @@ -64,13 +64,13 @@ solveNumMeta mine e nv = case (e, numVars nv) of unifyNum :: (End -> Maybe String) -> NumVal (VVar Z) -> NumVal (VVar Z) -> Checking () unifyNum mine nv0 nv1 = do - trailM $ ("unifyNum In\n " ++ show nv0 ++ "\n " ++ show nv1) + trailM ("unifyNum In\n " ++ show nv0 ++ "\n " ++ show nv1) nv0 <- numEval S0 nv0 nv1 <- numEval S0 nv1 unifyNum' mine (quoteNum Zy nv0) (quoteNum Zy nv1) nv0 <- numEval S0 (quoteNum Zy nv0) nv1 <- numEval S0 (quoteNum Zy nv1) - trailM $ ("unifyNum Out\n " ++ show (quoteNum Zy nv0) ++ "\n " ++ show (quoteNum Zy nv1)) + trailM ("unifyNum Out\n " ++ show (quoteNum Zy nv0) ++ "\n " ++ show (quoteNum Zy nv1)) -- Need to keep track of which way we're solving - which side is known/unknown -- Things which are dynamically unknown must be Tgts - information flows from Srcs @@ -101,14 +101,14 @@ unifyNum' mine (NumValue lup lgro) (NumValue rup rgro) (VPar e@(InEnd p), VPar e'@(ExEnd dangling)) | Just _ <- mine e -> do req (Wire (dangling, TNat, p)) - defineTgt' ("flex-flex In Ex") (NamedPort p "") (VNum (nVar v')) + defineTgt' "flex-flex In Ex" (NamedPort p "") (VNum (nVar v')) | Just _ <- mine e' -> do req (Wire (dangling, TNat, p)) - defineSrc' ("flex-flex In Ex") (NamedPort dangling "") (VNum (nVar v)) + defineSrc' "flex-flex In Ex" (NamedPort dangling "") (VNum (nVar v)) | otherwise -> mkYield "flexFlex" (S.singleton e) >> unifyNum mine (nVar v) (nVar v') (VPar e@(InEnd p), VPar e'@(InEnd p')) | Just _ <- mine e -> defineTgt' "flex-flex In In1" (NamedPort p "") (VNum (nVar v')) - | Just _ <- mine e' -> defineTgt' "flex-flex In In0"(NamedPort p' "") (VNum (nVar v)) + | Just _ <- mine e' -> defineTgt' "flex-flex In In0" (NamedPort p' "") (VNum (nVar v)) | otherwise -> mkYield "flexFlex" (S.fromList [e, e']) >> unifyNum mine (nVar v) (nVar v') lhsStrictMono :: StrictMono (VVar Z) -> NumVal (VVar Z) -> Checking () @@ -159,7 +159,7 @@ unifyNum' mine (NumValue lup lgro) (NumValue rup rgro) -- = 2^k + 2^k * y -- Hence, the predecessor is (2^k - 1) + (2^k * y) demandSucc (NumValue k x) | k > 0 = pure (NumValue (k - 1) x) - demandSucc (NumValue 0 (StrictMonoFun (mono@(StrictMono k (Linear (VPar e)))))) + demandSucc (NumValue 0 (StrictMonoFun mono@(StrictMono k (Linear (VPar e))))) | Just loc <- mine e = do pred <- loc -! traceChecking "makePred" makePred e pure (nPlus ((2^k) - 1) (nVar (VPar pred))) diff --git a/brat/Brat/Checker/SolvePatterns.hs b/brat/Brat/Checker/SolvePatterns.hs index cd49a366..af0eb518 100644 --- a/brat/Brat/Checker/SolvePatterns.hs +++ b/brat/Brat/Checker/SolvePatterns.hs @@ -128,14 +128,16 @@ solve my ((src, PCon c abs):p) = do typeOfEnd :: Modey m -> End -> Checking (BinderType m) -typeOfEnd my e = (req (TypeOf e) <&> fst) >>= \case - EndType my' ty - | Just Refl <- testEquality my my' -> case my' of - Braty -> case ty of - Right ty -> Right <$> eval S0 ty - _ -> pure ty - Kerny -> eval S0 ty - | otherwise -> err . InternalError $ "Expected end " ++ show e ++ " to be in a different mode" +typeOfEnd my e = do + (ty, _) <- req (TypeOf e) + case ty of + EndType my' ty + | Just Refl <- testEquality my my' -> case my' of + Braty -> case ty of + Right ty -> Right <$> eval S0 ty + _ -> pure ty + Kerny -> eval S0 ty + | otherwise -> err . InternalError $ "Expected end " ++ show e ++ " to be in a different mode") solveConstructor :: EvMode m diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index f0b1f644..4c95a0e0 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -224,7 +224,7 @@ compileArithNode parent op TFloat = addNode (show op ++ "_Float") (parent, OpCus compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty dumpJSON :: Compile BS.ByteString -dumpJSON = gets hugr <&> (encode . H.serialize) +dumpJSON = gets ((encode . H.serialize) . hugr) compileClauses :: NodeId -> [TypedPort] -> NonEmpty (TestMatchData m, Name) -> Compile [TypedPort] compileClauses parent ins ((matchData, rhs) :| clauses) = do @@ -290,10 +290,9 @@ compileTarget parent tgtN tgt = do edges <- compileInEdges parent tgt -- 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)] -in_edges name = gets bratGraph <&> \(_, es) -> [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name] +in_edges name = gets ((\(_, es) -> [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name]) . bratGraph) compileInEdges :: NodeId -> Name -> Compile [(PortId NodeId, Int)] compileInEdges parent name = do @@ -314,7 +313,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case -- 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 :: Compile (Maybe (NodeId, [(PortId NodeId, Int)])) - compileNode = case (hasPrefix ["checking", "globals", "decl"] name) of + 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). @@ -398,7 +397,6 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case 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 @@ -446,7 +444,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case outs -> error $ "Unexpected outs of box: " ++ show outs Source -> error "Source found outside of compileBox" - + Target -> error "Target found outside of compileBox" Id | Nothing <- hasPrefix ["checking", "globals", "decl"] name -> default_edges <$> do @@ -716,10 +714,10 @@ makeConditional :: String -- Label makeConditional lbl parent discrim otherInputs cases = do condId <- freshNode "Conditional" parent let rows = getSumVariants (snd discrim) - (outTyss_cases) <- for (zip (zip [0..] cases) rows) (\((ix, (name, f)), row) -> makeCase condId name ix (row ++ (snd <$> otherInputs)) f) + 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") + else error "Conditional output types didn't match" let condOp = OpConditional (Conditional rows (snd <$> otherInputs) outTys [("label", lbl)]) setOp condId condOp onHugr $ H.setFirstChildren condId (snd <$> outTyss_cases) diff --git a/brat/Brat/Eval.hs b/brat/Brat/Eval.hs index d7ee14c6..5b17c0eb 100644 --- a/brat/Brat/Eval.hs +++ b/brat/Brat/Eval.hs @@ -192,11 +192,11 @@ kindEq (TypeFor m xs) (TypeFor m' ys) | m == m' = kindListEq xs ys kindEq k k' = Left . TypeErr $ "Unequal kinds " ++ show k ++ " and " ++ show k' kindOf :: VVar Z -> Checking TypeKind -kindOf (VPar e) = (req (TypeOf e) <&> fst) >>= \case +kindOf (VPar e) = req (TypeOf e) >>= (\case EndType Braty (Left k) -> pure k EndType my ty -> typeErr $ "End " ++ show e ++ " isn't a kind, it's type is " ++ case my of Braty -> show ty - Kerny -> show ty + Kerny -> show ty) . fst kindOf (VInx n) = case n of {} -------- for SolvePatterns usage: not allowed to solve hopes, diff --git a/brat/Brat/Load.hs b/brat/Brat/Load.hs index 75570454..e6f0a385 100644 --- a/brat/Brat/Load.hs +++ b/brat/Brat/Load.hs @@ -155,7 +155,7 @@ loadStmtsWithEnv ns (venv, oldDecls, oldEndData) (fname, pre, stmts, cts) = addS (_, unders, overs, _) <- prefix -! next (show name) thing (S0, Some (Zy :* S0)) ins outs pure ((name, VDecl d{fnSig=sig}), (unders, overs)) trackM "finished kind checking" - unless (length holes == 0) $ error "Should be no holes from kind-checking" + unless (null holes) $ error "Should be no holes from kind-checking" unless (M.null capSets) $ error "Should be no captures from kind-checking" -- We used to check there were no holes from that, but for now we do not bother -- A list of local functions (read: with bodies) to define with checkDecl diff --git a/brat/Control/Monad/Freer.hs b/brat/Control/Monad/Freer.hs index ed8b7455..a94dc116 100644 --- a/brat/Control/Monad/Freer.hs +++ b/brat/Control/Monad/Freer.hs @@ -23,7 +23,7 @@ updateEnd (News m) e = case M.lookup e m of -- The RHS of the operation is the newer news -- Invariant: The domains of these Newses are disjoint instance Semigroup News where - (News m1) <> n2@(News m2) = News (m2 `M.union` (M.map (/// n2) m1)) + (News m1) <> n2@(News m2) = News (m2 `M.union` M.map (/// n2) m1) instance Monoid News where mempty = News M.empty @@ -86,7 +86,7 @@ instance Applicative (Free sig) where -- Make progress on the left Ret f <*> ma = fmap f ma Req sig k <*> ma = Req sig ((<*> ma) . k) - Define lbl e v k1 <*> ma = Define lbl e v $ \n -> (k1 n) <*> (ma /// n) + Define lbl e v k1 <*> ma = Define lbl e v $ \n -> k1 n <*> (ma /// n) -- What happens when Yield is on the left y <*> Ret v = fmap ($ v) y diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 8c5dfe89..50d88065 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -107,7 +107,7 @@ getOp HugrGraph {nodes} n = nodes M.! n -- 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 +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 -- 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 @@ -157,7 +157,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 @@ -168,8 +168,8 @@ splice_new hole add = modify $ \(host, ns) -> inlineDFG :: Ord n => n -> State (HugrGraph n) () 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 + 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 @@ -186,7 +186,7 @@ inlineDFG dfg = get >>= \h -> case M.lookup dfg (nodes h) of -- 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)] + | (n,p) <- M.assocs (parents h), notElem n to_remove] } other -> error $ "Expected DFG, found " ++ show other where @@ -208,7 +208,7 @@ takeInEdges tgt = do 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) + removeFromOutList (e:es) r = e:removeFromOutList es r takeOutEdges :: forall n. Ord n => n -> State (HugrGraph n) [(Int, PortId n)] takeOutEdges src = do @@ -226,7 +226,7 @@ takeOutEdges src = do 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) + removeFromInList (e:es) r = e:removeFromInList es r serialize :: forall n. (Ord n, Show n) => HugrGraph n -> Hugr Int serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) @@ -236,7 +236,7 @@ serialize hugr = renameAndSort (execState (for_ orderEdges addOrderEdge) hugr) -- 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), + parentOf n1 /= parentOf n2, requiresOrderEdge n1, requiresOrderEdge n2] in track ("interEdges: " ++ show interEdges) (walkUp <$> interEdges) @@ -262,14 +262,14 @@ type StackAndIndices n = (Bwd (n, HugrOp) -- node is index, this is (parent, op) renameAndSort :: forall n. Ord n => HugrGraph n -> Hugr Int renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr ( - (first transNode) <$> (fst nodeStackAndIndices) <>> [], + 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 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,4 +283,4 @@ renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr in foldl addNode with_n (first_children n) transNode :: n -> Int - transNode = ((snd nodeStackAndIndices) M.!) + transNode = (snd nodeStackAndIndices M.!) diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 6124f4e9..aa9e06e0 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" @@ -28,8 +28,7 @@ invalidExamples = (map ((++ ".brat") . ("examples" )) ,"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" -- 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) + ,"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. diff --git a/brat/test/Test/Util.hs b/brat/test/Test/Util.hs index 4aecf26f..7b36bf7c 100644 --- a/brat/test/Test/Util.hs +++ b/brat/test/Test/Util.hs @@ -24,7 +24,7 @@ assertCheckingFail :: Show a => String -> Checking a -> Assertion assertCheckingFail needle m = case runEmpty $ localFC (FC (Pos 0 0) (Pos 0 0)) m of Right res -> assertFailure ("Computation produced result " ++ show res ++ " when should have Thrown") Left err -> let shown = showError err in - if isInfixOf needle shown then pure () else assertFailure ("Unexpected error " ++ shown) + if needle `isInfixOf` shown then pure () else assertFailure ("Unexpected error " ++ shown) expectFailForPaths :: [FilePath] -> (FilePath -> TestTree) -> [FilePath] -> [TestTree] expectFailForPaths xf makeTest paths = if S.null not_found then tests else From f2c79d23fa66a503031f35e725b64e66ef31af45 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 3 Mar 2026 14:00:41 +0000 Subject: [PATCH 3/4] More lints --- brat/Brat/Checker/SolvePatterns.hs | 3 +- brat/Brat/Compile/Hugr.hs | 10 ++-- brat/Brat/Eval.hs | 2 +- brat/Data/HugrGraph.hs | 82 +++++++++++++++--------------- brat/test/Test/HugrGraph.hs | 15 +++--- 5 files changed, 55 insertions(+), 57 deletions(-) diff --git a/brat/Brat/Checker/SolvePatterns.hs b/brat/Brat/Checker/SolvePatterns.hs index af0eb518..5f1857fb 100644 --- a/brat/Brat/Checker/SolvePatterns.hs +++ b/brat/Brat/Checker/SolvePatterns.hs @@ -22,7 +22,6 @@ import Brat.Syntax.Port (toEnd) import Control.Monad (unless) import Data.Bifunctor (first) -import Data.Functor ((<&>)) import qualified Data.Map as M import Data.Maybe (fromJust) import Data.Type.Equality ((:~:)(..), testEquality) @@ -137,7 +136,7 @@ typeOfEnd my e = do Right ty -> Right <$> eval S0 ty _ -> pure ty Kerny -> eval S0 ty - | otherwise -> err . InternalError $ "Expected end " ++ show e ++ " to be in a different mode") + | otherwise -> err . InternalError $ "Expected end " ++ show e ++ " to be in a different mode" solveConstructor :: EvMode m diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 4c95a0e0..591ee2b8 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -291,13 +291,13 @@ compileTarget parent tgtN tgt = do -- registerCompiled tgt tgtN -- really shouldn't be necessary, not reachable for_ edges (\(src, tgtPort) -> addEdge (src, Port tgtN tgtPort)) -in_edges :: Name -> Compile [((OutPort, Val Z), Int)] -in_edges name = gets ((\(_, es) -> [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name]) . bratGraph) +inEdges :: Name -> Compile [((OutPort, Val Z), Int)] +inEdges name = gets ((\(_, es) -> [((src, ty), portNum) | (src, ty, In edgTgt portNum) <- es, edgTgt == name]) . bratGraph) 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)) + inEdges <- inEdges name + catMaybes <$> for inEdges (\((src, _), tgtPort) -> getOutPort parent src <&> fmap (, tgtPort)) compileWithInputs :: NodeId -> Name -> Compile (Maybe NodeId) compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case @@ -318,7 +318,7 @@ compileWithInputs parent name = gets (M.lookup name . compiled) >>= \case -- 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)) + hTys <- inEdges name <&> (map (compileType . snd . fst) . sortBy (comparing snd)) decls <- gets decls let (funcDef, extra_call) = decls M.! name diff --git a/brat/Brat/Eval.hs b/brat/Brat/Eval.hs index 5b17c0eb..6f063926 100644 --- a/brat/Brat/Eval.hs +++ b/brat/Brat/Eval.hs @@ -134,7 +134,7 @@ quoteCTy lvy my ga (ins :->> outs) = quoteRo my ga ins lvy >>= \case (_, Some (outs' :* _)) -> pure (ins' :->> outs') quoteNum :: Ny lv -> NumVal SVar -> NumVal (VVar lv) -quoteNum lvy num = fmap (quoteVar lvy) num +quoteNum lvy = fmap (quoteVar lvy) -- first number is next Lvl to use in Value -- require every Lvl in Sem is < n (converted by n - 1 - lvl), else must fail at runtime diff --git a/brat/Data/HugrGraph.hs b/brat/Data/HugrGraph.hs index 50d88065..3ac1f383 100644 --- a/brat/Data/HugrGraph.hs +++ b/brat/Data/HugrGraph.hs @@ -7,7 +7,7 @@ module Data.HugrGraph(NodeId, setOp, getParent, getOp, addEdge, addOrderEdge, serialize, - splice, splice_new, splice_prepend, inlineDFG + splice, spliceNew, splicePrepend, inlineDFG ) where import Brat.Naming (Namespace, Name(..), fresh) @@ -28,10 +28,10 @@ newtype NodeId = NodeId Name deriving (Eq, Ord, Show) data HugrGraph n = HugrGraph { root :: n, parents :: M.Map n n, -- definitive list of (valid) nodes, excluding root - first_children:: M.Map n [n], + firstChildren:: 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)] + edgesOut :: M.Map n [(Int, PortId n)], + edgesIn :: M.Map n [(PortId n, Int)] } deriving (Eq, Show) -- we probably want a better `show` freshNode :: NodeId -> String -> State (HugrGraph NodeId, Namespace) NodeId @@ -45,8 +45,8 @@ freshNode parent nam = state $ \(hugr@HugrGraph {root, parents}, nameSupply) -> -- ERRORS if firstChildren already set for this node 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} +setFirstChildren p cs = modify $ \h -> let nch = M.alter (\Nothing -> Just cs) p (firstChildren h) + in h {firstChildren = nch} -- ERRORS if op already set for this node (or node does not have parent - should not be possible) setOp :: (Ord n, Show n) => n -> HugrOp -> State (HugrGraph n) () @@ -64,10 +64,10 @@ new nam op = state $ \ns -> in (HugrGraph { root, parents = M.empty, - first_children = M.empty, + firstChildren = M.empty, nodes = M.singleton root op, - edges_in = M.empty, - edges_out = M.empty} + edgesIn = M.empty, + edgesOut = M.empty} ,ns' ) @@ -75,8 +75,8 @@ 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 { - edges_out = addToMap s (o, tgt) edges_out id, - edges_in = addToMap t (src, i) edges_in no_other_inedge + edgesOut = addToMap s (o, tgt) edgesOut id, + edgesIn = addToMap t (src, i) edgesIn no_other_inedge } _ -> error "addEdge to/from node not present" where @@ -91,7 +91,7 @@ addOrderEdge :: Ord n => (n, n) -> State (HugrGraph n) () addOrderEdge (src, tgt) = addEdge (Port src orderEdgeOffset, Port tgt orderEdgeOffset) edgeList :: HugrGraph n -> [(PortId n, PortId n)] -edgeList (HugrGraph {edges_out}) = [(Port n off, tgt) | (n, vs) <- M.assocs edges_out +edgeList (HugrGraph {edgesOut}) = [(Port n off, tgt) | (n, vs) <- M.assocs edgesOut , (off, tgt) <- vs ] @@ -116,10 +116,10 @@ splice hole add non_root_k = modify $ \host -> case M.lookup hole (nodes host) > 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 = 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) + edgesIn = disj_union (edgesIn host) new_edgesIn, + edgesOut = disj_union (edgesOut host) new_edgesOut, + firstChildren = disj_union (firstChildren host) + (M.mapKeys k $ M.map (k <$>) $ firstChildren add) } other -> error $ "Expected DFG with sig " ++ show sig ++ "\nBut found: " ++ show other other -> error $ "Expected a hole, found " ++ show other @@ -127,21 +127,21 @@ 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 - new_edges_in = M.fromList [(k tgt, [(Port (k srcNode) srcPort, tgtPort) + new_edgesIn = M.fromList [(k tgt, [(Port (k srcNode) srcPort, tgtPort) | (Port srcNode srcPort, tgtPort) <- in_edges ]) - | (tgt, in_edges ) <- M.assocs (edges_in add)] + | (tgt, in_edges ) <- M.assocs (edgesIn add)] - new_edges_out = M.fromList [(k src, [(srcPort, Port (k tgtNode) tgtPort) + new_edgesOut = M.fromList [(k src, [(srcPort, Port (k tgtNode) tgtPort) | (srcPort, Port tgtNode tgtPort) <- out_edges]) - | (src, out_edges) <- M.assocs (edges_out add)] + | (src, out_edges) <- M.assocs (edgesOut 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 -- the hole -splice_prepend :: NodeId -> HugrGraph NodeId -> State (HugrGraph NodeId) () -splice_prepend hole add = splice hole add (keyMap M.!) +splicePrepend :: NodeId -> HugrGraph NodeId -> State (HugrGraph NodeId) () +splicePrepend hole add = splice hole add (keyMap M.!) where prefixRoot :: NodeId -> NodeId prefixRoot (NodeId (MkName ids)) = let NodeId (MkName rs) = hole in NodeId $ MkName (rs ++ ids) @@ -154,8 +154,8 @@ splice_prepend hole add = splice hole add (keyMap M.!) -- 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) -> +spliceNew :: forall n. (Ord n, Show n) => NodeId -> HugrGraph n -> State (HugrGraph NodeId, Namespace) () +spliceNew hole add = modify $ \(host, ns) -> let (ns_out, keyMap) = foldr newMapping (ns, M.empty) (M.keys (parents add)) newMapping :: n -> (Namespace, M.Map n NodeId) -> (Namespace, M.Map n NodeId) @@ -169,7 +169,7 @@ inlineDFG :: Ord n => n -> State (HugrGraph n) () 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 + let [inp, out] = firstChildren h M.! dfg -- rewire edges dfg_in_map <- takeInEdgeMap dfg input_out_map <- takeOutEdges inp @@ -180,13 +180,13 @@ inlineDFG dfg = get >>= \h -> case M.lookup dfg (nodes h) of -- 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 + firstChildren = M.delete dfg (firstChildren 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), notElem n to_remove] + | (n,p) <- M.assocs (parents h), n `notElem` to_remove] } other -> error $ "Expected DFG, found " ++ show other where @@ -195,10 +195,10 @@ inlineDFG dfg = get >>= \h -> case M.lookup dfg (nodes h) of takeInEdges :: forall n. Ord n => n -> State (HugrGraph n) [(PortId n, 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'} + let (removed_edges, edgesIn') = first (fromMaybe []) $ M.updateLookupWithKey + (\_ _ -> Nothing) tgt (edgesIn h) + let edgesOut' = foldl removeFromOutMap (edgesOut h) removed_edges + put h {edgesIn=edgesIn', edgesOut=edgesOut'} pure removed_edges where removeFromOutMap :: M.Map n [(Int, PortId n)] -> (PortId n, Int) -> M.Map n [(Int, PortId n)] @@ -213,10 +213,10 @@ takeInEdges tgt = do takeOutEdges :: forall n. Ord n => n -> State (HugrGraph n) [(Int, PortId n)] 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'} + let (removed_edges, edgesOut') = first (fromMaybe []) $ M.updateLookupWithKey + (\_ _ -> Nothing) src (edgesOut h) + let edgesIn' = foldl removeFromInMap (edgesIn h) removed_edges + put h {edgesIn=edgesIn', edgesOut=edgesOut'} pure removed_edges where removeFromInMap :: M.Map n [(PortId n, Int)] -> (Int, PortId n) -> M.Map n [(PortId n, Int)] @@ -261,14 +261,14 @@ type StackAndIndices n = (Bwd (n, HugrOp) -- node is index, this is (parent, op) , M.Map n Int) renameAndSort :: forall n. Ord n => HugrGraph n -> Hugr Int -renameAndSort hugr@(HugrGraph {root, first_children=fc, nodes, parents}) = Hugr ( +renameAndSort hugr@(HugrGraph {root, firstChildren=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 + firstChildren k = M.findWithDefault [] k fc 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) + in foldl' addNode just_root (firstChildren root ++ M.keys parents) addNode :: StackAndIndices n -> n -> StackAndIndices n addNode ins n = case M.lookup n (snd ins) of @@ -277,10 +277,10 @@ 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 firstChildren 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) + -- finally add firstChildren immediately after n + in foldl addNode with_n (firstChildren n) transNode :: n -> Int transNode = (snd nodeStackAndIndices M.!) diff --git a/brat/test/Test/HugrGraph.hs b/brat/test/Test/HugrGraph.hs index a9d93953..0d6e8fbd 100644 --- a/brat/test/Test/HugrGraph.hs +++ b/brat/test/Test/HugrGraph.hs @@ -4,9 +4,8 @@ import Brat.Naming as N import Data.HugrGraph as H import Data.Hugr -import Control.Monad.State (State, execState, get, runState, modify, state) +import Control.Monad.State (State, execState, gets, runState, modify, state) import Data.Aeson (encode) -import Data.Functor ((<&>)) import Data.Maybe (isJust, isNothing) import Data.List (find) import qualified Data.ByteString.Lazy as BS @@ -36,8 +35,8 @@ testSplice inline prepend = testCaseInfo name $ do BS.writeFile (outPrefix ++ "_host.json") (encode $ H.serialize h) BS.writeFile (outPrefix ++ "_insertee.json") (encode $ H.serialize dfgHugr) let spliced = if prepend - then execState (H.splice_prepend holeId dfgHugr) h - else fst $ execState (H.splice_new holeId dfgHugr) (h, ns) + then execState (H.splicePrepend holeId dfgHugr) h + else fst $ execState (H.spliceNew holeId dfgHugr) (h, ns) let resHugr@(Hugr (ns, _)) = H.serialize $ if inline then execState (inlineDFG holeId) spliced else spliced let outFile = outPrefix ++ "_result.json" @@ -49,10 +48,10 @@ 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 <- gets (H.root . fst) input <- addNode "inp" root (OpIn (InputNode tys [])) output <- addNode "out" root (OpOut (OutputNode tys [])) - jh $setFirstChildren root [input, output] + jh $ setFirstChildren root [input, output] hole <- addNode "hole" root (OpCustom $ holeOp 0 tq_ty) jh $ H.addEdge (Port input 0, Port hole 0) jh $ H.addEdge (Port input 1, Port hole 1) @@ -63,7 +62,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 <- gets (H.root . fst) input <- addNode "inp" root (OpIn (InputNode tys [])) output <- addNode "out" root (OpOut (OutputNode tys [])) jh $ setFirstChildren root [input, output] @@ -80,4 +79,4 @@ testSplice inline prepend = testCaseInfo name $ do jh :: State (HugrGraph NodeId) a -> State (HugrGraph NodeId, Namespace) a jh action = state $ \ (h, ns) -> - let (a, h') = runState action h in (a, (h', ns)) \ No newline at end of file + let (a, h') = runState action h in (a, (h', ns)) From f354a992a93f05947bd5cbb02435110f5f97e13b Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 3 Mar 2026 14:11:44 +0000 Subject: [PATCH 4/4] Don't fail hlint action --- .github/workflows/hlint.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/hlint.yaml b/.github/workflows/hlint.yaml index 0daa766d..fbf50d69 100644 --- a/.github/workflows/hlint.yaml +++ b/.github/workflows/hlint.yaml @@ -20,4 +20,4 @@ jobs: path: brat/ # https://github.com/haskell-actions/hlint-run/issues/20#issuecomment-2168787894 hlint-bin: hlint --hint=brat/.hlint.yaml - fail-on: warning + fail-on: error