refactor: Remove findAndAdjustA and adjustAtA'

We can define these in terms of their un-primed equivalents, by choosing the correct applicative, so we effectively do so and then inline.

Signed-off-by: George Thomas <[email protected]>

Author: georgefst

primer/src/Foreword.hs

@@ -32,8 +32,6 @@ module Foreword (
   curry4,
   unsafeMaximum,
   spanMaybe,
-  adjustAtA',
-  findAndAdjustA',
 ) where
 
 -- In general, we should defer to "Protolude"'s exports and avoid name
@@ -132,11 +130,6 @@ adjustAtA n f xs = case splitAt n xs of
   (a, b : bs) -> f b <&> \b' -> Just $ a ++ [b'] ++ bs
   _ -> pure Nothing
 
-adjustAtA' :: Applicative f => Int -> (a -> f (a, z)) -> [a] -> f (Maybe ([a], z))
-adjustAtA' n f xs = case splitAt n xs of
-  (a, b : bs) -> f b <&> \(b', z) -> Just (a ++ [b'] ++ bs, z)
-  _ -> pure Nothing
-
 -- | Adjust the first element of the list which satisfies the
 -- predicate. Returns 'Nothing' if there is no such element.
 findAndAdjust :: (a -> Bool) -> (a -> a) -> [a] -> Maybe [a]
@@ -150,11 +143,6 @@ findAndAdjustA p f = \case
   [] -> pure Nothing
   x : xs -> if p x then Just . (: xs) <$> f x else (x :) <<$>> findAndAdjustA p f xs
 
-findAndAdjustA' :: Applicative m => (a -> Bool) -> (a -> m (a, z)) -> [a] -> m (Maybe ([a], z))
-findAndAdjustA' p f = \case
-  [] -> pure Nothing
-  x : xs -> if p x then (\(x', z) -> Just . (,z) . (: xs) $ x') <$> f x else first (x :) <<$>> findAndAdjustA' p f xs
-
 -- | Change the type of an error.
 modifyError :: MonadError e' m => (e -> e') -> ExceptT e m a -> m a
 modifyError f = runExceptT >=> either (throwError . f) pure

primer/src/Primer/Action.hs

@@ -27,13 +27,16 @@ import Foreword hiding (mod)
 import Control.Monad.Fresh (MonadFresh)
 import Data.Aeson (Value)
 import Data.Bifunctor.Swap qualified as Swap
+import Data.Bitraversable (bisequence)
+import Data.Functor.Compose (Compose (..))
 import Data.Generics.Product (typed)
 import Data.List (findIndex)
 import Data.List.NonEmpty qualified as NE
 import Data.Map (insert)
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
+import Data.Tuple.Extra ((&&&))
 import Optics (over, set, (%), (?~), (^.), (^?), _Just)
 import Primer.Action.Actions (Action (..), Movement (..), QualifiedText)
 import Primer.Action.Available qualified as Available
@@ -260,16 +263,23 @@ applyActionsToField smartHoles imports (mod, mods) (tyName, conName', index, tyD
   where
     go :: ActionM m => m ([Module], TypeZ)
     go = do
+      (tz, cs) <-
+        getCompose
+          . flip (findAndAdjustA ((== conName') . valConName)) (astTypeDefConstructors tyDef)
+          $ Compose . \(ValCon _ ts) -> do
+            (tz', cs') <-
+              getCompose . flip (adjustAtA index) ts $
+                Compose
+                  . fmap (First . Just &&& target . top)
+                  . flip withWrappedType \tz'' ->
+                    foldlM (\l a -> local addParamsToCxt $ applyActionAndSynth a l) (InType tz'') actions
+            maybe
+              (throwError $ InternalFailure "applyActionsToField: con field index out of bounds")
+              (pure . first (First . Just))
+              $ bisequence (getFirst tz', ValCon conName' <$> cs')
       (valCons, zt) <-
-        (maybe (throwError $ InternalFailure "applyActionsToField: con name not found") pure =<<) $
-          flip (findAndAdjustA' ((== conName') . valConName)) (astTypeDefConstructors tyDef) \(ValCon _ ts) -> do
-            (t, zt) <-
-              maybe (throwError $ InternalFailure "applyActionsToField: con field index out of bounds") pure
-                =<< flip (adjustAtA' index) ts \fieldType -> do
-                  zt <- withWrappedType fieldType \zt ->
-                    foldlM (\l -> local addParamsToCxt . flip applyActionAndSynth l) (InType zt) actions
-                  pure (target (top zt), zt)
-            pure (ValCon conName' t, zt)
+        maybe (throwError $ InternalFailure "applyActionsToField: con name not found") pure $
+          bisequence (cs, getFirst tz)
       let mod' = mod{moduleTypes = insert tyName (TypeDefAST tyDef{astTypeDefConstructors = valCons}) $ moduleTypes mod}
       (,zt) <$> checkEverything smartHoles (CheckEverything{trusted = imports, toCheck = mod' : mods})
     addParamsToCxt :: TC.Cxt -> TC.Cxt