MaybeOp.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Test.Syd.Mutation.Plugin.Operator.MaybeOp (theOperator) where

import GHC
import GHC.Hs.Syn.Type (lhsExprType)
import GHC.Types.Name (getOccString)
import Test.Syd.Mutation.Plugin.Instrument (InstrM, MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))
import Test.Syd.Mutation.Plugin.Operator.Util (mkNothingExpr)

theOperator :: MutationOperator
theOperator =
  MutationOperator
    { operatorName = "MaybeOp",
      operatorDescription = "Replace Just e with Nothing",
      operatorKind = ExpressionOperator $ \case
        le@(L _ (HsApp _ f _))
          | Just occ <- funOccName f,
            occ == "Just" ->
              Just (action le)
        _ -> Nothing
    }

-- | Extract the OccName string of the function in an application, handling
-- typechecker wrappers.  After typechecking, data constructors like @Just@
-- are rewritten from @HsVar@ to @XExpr (ConLikeTc ...)@, so we have to
-- inspect that form too — mirroring 'BoolLit.extractBoolLit'.
funOccName :: LHsExpr GhcTc -> Maybe String
funOccName = \case
  L _ (HsVar _ (L _ v)) -> Just (getOccString v)
  L _ (XExpr (ConLikeTc con _ _)) -> Just (getOccString con)
  L _ (XExpr (WrapExpr (HsWrap _ e))) -> funOccName (noLocA e)
  _ -> Nothing

action ::
  LHsExpr GhcTc ->
  InstrM [MutationAlt]
action le =
  -- lhsExprType gives Maybe a, which is the type for the ifMutation wrapper.
  -- 'mkNothingExpr' instantiates Nothing's type variable to that element type;
  -- a bare 'nlHsDataCon nothingDataCon' would be @forall a. Maybe a@ and make
  -- the surrounding @ifMutation \@ty@ wrapper ill-typed (see 'mkNothingExpr').
  let mayTy = lhsExprType le
      nothingExpr = mkNothingExpr mayTy
   in pure
        [ MutationAlt
            { mutAltType = mayTy,
              mutAltExpr = nothingExpr,
              mutAltOriginal = "Just e",
              mutAltReplacement = "Nothing",
              mutAltDelta = TokenReplace "Nothing",
              mutAltMitigation = Nothing
            }
        ]