chore: Fix hlint action and apply changes

.github/workflows/hlint.yaml

@@ -1,6 +1,9 @@
 name: Brat CI
 on:
-  pull_request: []
+  pull_request:
+    branches: [main]
+    paths:
+      - "**.hs"
 
 jobs:
   hlint:
@@ -17,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

brat/Brat/Checker.hs

@@ -763,7 +763,7 @@
           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 @@
      -- 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
@@ -809,7 +809,7 @@
          outPorts <- depOutPorts def
          srcAndTys <- for outPorts (\outport -> (NamedPort outport "",) <$> typeOfEnd Braty (ExEnd outport))
          zx <- pure $ foldl (\sol srcAndTy -> insert ("$" ++ show (end (fst srcAndTy)), srcAndTy) sol) zx srcAndTys
          (sol, defs) <- worker (zx {-:< entry-}) sol
          pure ({-(patVar, (src, Left k)):-}sol, ((patVar, k), def):defs)
     -- Pat vars beginning with '_' aren't in scope, we can ignore them
     -- (but if they're kinded they might come up later as the dependency of something else)
@@ -1289,6 +1289,6 @@
     -- 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

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

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)))

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)
@@ -128,14 +127,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

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,15 +290,14 @@ 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]
+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
@@ -314,12 +313,12 @@ 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).
       -- 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
@@ -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)

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
@@ -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,

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

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