Rework the protoeffect system

& Add ActingUnit/TargettedUnit newtypes

.hlint.yaml

@@ -0,0 +1,70 @@
+# HLint configuration file
+# https://github.com/ndmitchell/hlint
+##########################
+
+# This file contains a template configuration file, which is typically
+# placed as .hlint.yaml in the root of your project
+
+
+# Specify additional command line arguments
+#
+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
+
+
+# Control which extensions/flags/modules/functions can be used
+#
+# - extensions:
+#   - default: false # all extension are banned by default
+#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
+#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
+#
+# - flags:
+#   - {name: -w, within: []} # -w is allowed nowhere
+#
+# - modules:
+#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
+#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely
+#
+# - functions:
+#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
+
+
+# Add custom hints for this project
+#
+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
+
+# The hints are named by the string they display in warning messages.
+# For example, if you see a warning starting like
+#
+# Main.hs:116:51: Warning: Redundant ==
+#
+# You can refer to that hint with `{name: Redundant ==}` (see below).
+
+# Turn on hints that are off by default
+#
+# Ban "module X(module X) where", to require a real export list
+# - warn: {name: Use explicit module export list}
+#
+# Replace a $ b $ c with a . b $ c
+# - group: {name: dollar, enabled: true}
+#
+# Generalise map to fmap, ++ to <>
+# - group: {name: generalise, enabled: true}
+
+- group: {name: use-lens, enabled: true}
+- group: {name: generalise-for-conciseness, enabled: true}
+- group: {name: teaching, enabled: true}
+
+
+# Ignore some builtin hints
+# - ignore: {name: Use let}
+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
+
+
+# Define some custom infix operators
+# - fixity: infixr 3 ~^#^~
+
+
+# To generate a suitable file for HLint do:
+# $ hlint --default > .hlint.yaml

package.yaml

@@ -51,6 +51,7 @@ library:
   - ScopedTypeVariables
   - EmptyCase
   - DuplicateRecordFields
+  - StandaloneDeriving
 
 executables:
   maleghast-exe:

src/GameLogic.hs

@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -Wno-type-defaults #-}
 module GameLogic
     ( chooseCharacter
     , applyEffect
@@ -27,16 +26,16 @@ import Numeric.Natural (Natural)
 import Lens.Micro
 import Safe (atMay)
 
-import Debug.Trace
 import Mechanics (universalModifiers, globalHooks)
 import Data.Monoid (Any(getAny), getSum)
+import Data.Coerce
 
 -- | A version of `computeStat_` using `universalModifiers` as global modifiers
-computeStat :: BoardState -> CharacterIdentifier -> Stat a -> a
+computeStat :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Stat a -> a
 computeStat = computeStat_ universalModifiers
 
 -- | A version of `runHooks_` using `globalHooks` as the global hooks
-runHooks :: Trigger -> BoardState -> BoardState
+runHooks :: Broadcast -> BoardState -> BoardState
 runHooks = runHooks_ globalHooks
 
 data EngineState
@@ -51,7 +50,7 @@ data EngineState
 playerChoice :: Player -> [Choice] -> EngineState
 playerChoice = PlayerChoice
 
-unitChoice :: CharacterIdentifier -> [Choice] -> EngineState
+unitChoice :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> [Choice] -> EngineState
 unitChoice = playerChoice . owner
 
 activePlayerChoice :: BoardState -> [Choice] -> EngineState
@@ -66,8 +65,8 @@ chooseCharacter board = playerChoice player <$> fmap toList (nonEmpty $ board ^.
     player :: Player
     player = board ^. activePlayer
     possibleActivations :: SimpleFold BoardState Choice
-    possibleActivations = untappedUnits . filtered ((== player) . owner) . to activateUnit
+    possibleActivations = untappedUnits . filtered ((== player) . owner) . to (activateUnit . ActingUnit)
-    activateUnit :: CharacterIdentifier -> Choice
+    activateUnit :: ActingUnit -> Choice
     activateUnit cid = mkChoice ("Activate unit " ++ c) [ChooseActMove cid]
       where
         c = renderCharacterHandle board cid
@@ -81,6 +80,7 @@ forcedMovementValidDirections w h currentLocation (locus, moveType, _) =
   where
     directionToLocus = identifyCardinalDirection w h currentLocation locus
 
+{-# ANN computePossibleSteps "HLint: ignore Apply De Morgan law" #-}
 computePossibleSteps :: BoardState -> MovementSpecs -> Point -> [(Point, Natural)]
 computePossibleSteps board (MovementSpecs {..}) currentLocation = mapMaybe getRemainingMov validDestinations
   where
@@ -110,8 +110,8 @@ computePossibleSteps board (MovementSpecs {..}) currentLocation = mapMaybe getRe
 endOfMovementEffects :: MovementSpecs -> CharacterIdentifier -> [Effect]
 endOfMovementEffects (MovementSpecs {..}) cid =
   [ConfirmMove]
-  ++ [DropToken SpeedSlow cid | movSpendTokens   ]
+  ++ [DropToken SpeedSlow (TargettedUnit cid)    | movSpendTokens   ]
-  ++ [Event $   EndMove   cid | movEndMoveTrigger]
+  ++ [Event $ Broadcast EndMove (ActingUnit cid) | movEndMoveTrigger]
 
 generateMovementChoice :: BoardState -> MovementSpecs -> CharacterIdentifier -> Point -> (Point, Natural) -> Choice
 generateMovementChoice board specs@(MovementSpecs {..}) cid originalLocation (dest, remainingMov) =
@@ -192,7 +192,7 @@ applyEffect (Move specs@(MovementSpecs{..}) cid) board = case unitPosition board
       then continue $ board <++ if movMinimum
         then dontMoveEffects
         else finishMoveEffects
-      else choiceBuilder $ (++ movementChoices) $ if movCompelled
+      else choiceBuilder . (++ movementChoices) $ if movCompelled
         then []
         else if movMinimum
           then [dontMoveChoice]
@@ -202,7 +202,7 @@ applyEffect (Move specs@(MovementSpecs{..}) cid) board = case unitPosition board
     dontMoveChoice    = mkChoice "Don't move" dontMoveEffects
     finishMoveEffects = endOfMovementEffects specs cid
     finishMoveChoice  = mkChoice "Finish moving" finishMoveEffects
-    endMoveTrigger = Event $ EndMove cid
+    endMoveTrigger = Event $ Broadcast EndMove (ActingUnit cid)
     choiceBuilder = maybe (unitChoice cid) playerChoice $ movForced ^? _Just . _3
 applyEffect (MoveTo dest) board = continue $ moveUnit dest board
 applyEffect (DropToken token unit) board = continue $
@@ -214,22 +214,22 @@ applyEffect (Act cid) board = case board ^.. ixCharacter cid . baseStats . actio
 applyEffect (Target fromPerspective range eligability ultimateEffect) board = unitChoice fromPerspective choices
   where
     locus = unitPosition board fromPerspective
-    potentialUnits = maybe [] (cidsInRange board range) locus
+    potentialUnits = TargettedUnit <$> (maybe [] (cidsInRange board range) locus)
     eligableUnits = filter (eligability board) potentialUnits
     buildChoice targetCid =
       mkChoice
         ("Target " ++ renderCharacterHandle board targetCid)
         [BodyBlock targetCid ultimateEffect]
     choices = buildChoice <$> eligableUnits
-applyEffect (BodyBlock targettedUnit ultimateEffect) board = if canBB then allChoices else cantBBResult
+applyEffect (BodyBlock originalTarget ultimateEffect) board = if canBB then allChoices else cantBBResult
   where
-    potentialBBers = fromMaybe [] $ adjacentAllies board targettedUnit
+    potentialBBers = fromMaybe [] $ adjacentAllies board originalTarget
-    canBB = isNecromancer targettedUnit && potentialBBers /= []
+    canBB = isNecromancer originalTarget && not (null potentialBBers)
     buildChoice bber = mkChoice ("Bodyblock with " ++ renderCharacterHandle board bber) (ultimateEffect bber)
-    dontBodyblock = mkChoice "Take the hit to your necromancer" (ultimateEffect targettedUnit)
+    dontBodyblock = mkChoice "Take the hit to your necromancer" (ultimateEffect originalTarget)
-    bbChoices = buildChoice <$> potentialBBers
+    bbChoices = buildChoice . TargettedUnit <$> potentialBBers
-    allChoices = unitChoice targettedUnit $ dontBodyblock : bbChoices
+    allChoices = unitChoice originalTarget $ dontBodyblock : bbChoices
-    cantBBResult = continue $ board <++ ultimateEffect targettedUnit
+    cantBBResult = continue $ board <++ ultimateEffect originalTarget
 applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRolled keepHighest consequence
   where
     attacker' = board ^? ixCharacter attacker
@@ -252,7 +252,7 @@ applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRoll
     actualDiceRolled = fromIntegral $ if netDice <= 0 then 2 else netDice
     keepHighest = netDice > 0
     toHit = maybe 1 getDefense defender'
-    attackerStrWeak = fromMaybe 0 $ attacker' ^? _Just . tokenCount . ofToken StrWeak
+    attackerStrWeak = sum $ attacker' ^? _Just . tokenCount . ofToken StrWeak
     tokenDamageModifier
       | attackerStrWeak < 0 = \x -> x-1
       | attackerStrWeak > 0 = (+1)
@@ -263,7 +263,7 @@ applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRoll
     onHit = hitDamage : otherEffects attack
     onHeadshot = onHit ++ headshotEffects attack
     consequence Six
-      | not $ null $ headshotEffects attack = mkChoice "Headshot!" onHeadshot
+      | not . null $ headshotEffects attack = mkChoice "Headshot!" onHeadshot
     consequence r
       | r >= toHit = mkChoice "Hit!" onHit
       | otherwise = mkChoice "Graze" onMiss
@@ -273,28 +273,29 @@ applyEffect (InflictDamage damageType incomingAmount recipient) board = continue
     recipient' = board ^? ixCharacter recipient
     armorType = maybe NoArmor (^. baseStats . armL) recipient'
     armorReduction = if armorType `blocks` damageType then 1 else 0
-    tokenReduction = signum $ fromMaybe 0 $ recipient' ^? _Just . tokenCount . ofToken VitalVulnr
+    tokenReduction = signum . sum $ (recipient' ^? _Just . tokenCount . ofToken VitalVulnr)
     totalReduction = if damageType == DevilDamage then min 0 tokenReduction else armorReduction + tokenReduction
     netDamage
       | totalReduction >= incomingAmount' = 0
       | otherwise = fromIntegral $ incomingAmount' - totalReduction
-    board' = trace ("iA': " ++ show incomingAmount' ++ " | aR: " ++ show armorReduction ++ " | r: " ++ show recipient) $ board
+    board' = board
       & ixCharacter recipient %~ clearUpToNTokens Health netDamage
       & if incomingAmount' > armorReduction
         then ixCharacter recipient %~ removeTokenInCategory VitalVulnr
         else id
     updatedHealth = fromMaybe 9999 $ board' ^? ixCharacter recipient . tokenCount . ofToken Health
     dead = updatedHealth == 0
-    damageEffects = [Event $ TookDamage recipient, if dead then Kill recipient else NoOp]
+    damageEffects = [Event $ Broadcast TookDamage recipient, if dead then Kill recipient else NoOp]
+applyEffect (InflictStatusEffect se target) board = continue $ board & ixCharacter target . statusEffects %~ (se :)
 applyEffect (InflictTokens tokenType numberToAdd target) board = continue $ board &
   ixCharacter target . tokenCount . ofToken tokenType +~ numberToAdd
 applyEffect (Kill unit) board = if isNecromancer unit
-  then Victory $ otherPlayer $ owner unit
+  then Victory . otherPlayer $ owner unit
   else continue $ unitRemoved <++ [deathAlert]
   where
     deathLocation = unitPosition board unit
     unitRemoved = removeUnit unit board
-    deathAlert = maybe NoOp (Event . Died unit) deathLocation
+    deathAlert = maybe NoOp (Event . Broadcast Died . (unit,)) deathLocation
 applyEffect (EndTurn cid) board = continue $ afterPlayerSwitched <++ [StartTurn]
   where
     afterUnitTapped = board & ixCharacter cid %~ tap
@@ -319,7 +320,7 @@ instance Show (ChoiceTree' a) where
       choicesText :: [String]
       choicesText = firstDecisions choices
       numberedChoices :: [String]
-      numberedChoices = zipWith (\n c -> show (1+n) ++ ") " ++ c) [0..] choicesText
+      numberedChoices = zipWith (\n c -> show n ++ ") " ++ c) ([1..] :: [Int]) choicesText
       viewChoices :: String
       viewChoices = mconcat $ intersperse "\n" numberedChoices
   show (Random numDice rollType _) = "Roll " ++ show numDice ++ "d6 and take the " ++ (if rollType then "highest" else "lowest")
@@ -353,11 +354,11 @@ buildChoiceTree board = case popEffect board of
         PlayerChoice chooser choices -> ChoiceTree $ Node board' chooser (convertChoice board' <$> choices)
         Roll n d outcomes -> ChoiceTree $ Random n d (convertChoice board' <$> outcomes)
         Continue board'' -> buildChoiceTree board''
-        Victory player -> ChoiceTree $ EndOfGame $ Just player
+        Victory player -> ChoiceTree . EndOfGame $ Just player
 
 makeChoice :: n -> ChoiceTree' n -> Maybe ChoiceTree
 makeChoice n (EndOfGame _) = never n
-makeChoice die (Random _ _ outcomes) = Just $ ctTree $ outcomes die
+makeChoice die (Random _ _ outcomes) = Just . ctTree $ outcomes die
 makeChoice indx (Node b p options) = trimmedChoices <$> providedDecision
   where
     providedDecision :: Maybe String

src/GameModel.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# HLINT ignore "Eta reduce" #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 module GameModel
     ( DieFace(..)
@@ -8,6 +6,10 @@ module GameModel
     , Armor(..)
     , DamageType(..)
     , Attack(Attack)
+    , ActingUnit(..)
+    , actingUnit
+    , TargettedUnit(..)
+    , targettedUnit
     , headshotEffectsL
     , meleeL
     , otherEffectsL
@@ -49,6 +51,8 @@ module GameModel
     , otherPlayer
     , Token(..)
     , ofToken
+    , tokenEq
+    , Broadcast(..)
     , Stat(..)
     , BaseStats(..)
     , nameL
@@ -67,7 +71,9 @@ module GameModel
     , clearUpToNTokens
     , getSpeed
     , getDefense
+    , statusEffects
     , CharacterIdentifier
+    , cidEq
     , owner
     , ownerL
     , isNecromancer
@@ -128,8 +134,8 @@ module GameModel
     , allStatsAreMonoids
     , HasMonoidInstance
     , Hook(..)
-    , hookTriggerL
+    , hookToFunc
-    , hookEffectL
+    , hooksToFunc
     , Modifier(..)
     , Trait(..)
     , traitNameL
@@ -137,6 +143,7 @@ module GameModel
     , traitModifiersL
     , computeStat_
     , runHooks_
+    , StatusEffect(..)
     ) where
 
 import Util (toMaybe, dup, secondClassLensNames, (??))
@@ -156,6 +163,7 @@ import Lens.Micro.TH (makeLenses, makeLensesWith, generateUpdateableOptics)
 import Lens.Micro.Extras (preview)
 import Data.Data ((:~:)(..))
 import System.Random (Random(..))
+import Data.Coerce
 
 data DieFace = One | Two | Three | Four | Five | Six
   deriving (Eq, Ord, Enum, Read)
@@ -166,7 +174,7 @@ instance Random DieFace where
       lowN = fromEnum low
       hiN  = fromEnum hi
       (r, g') = randomR (lowN, hiN) g
-  random g = randomR (One, Six) g
+  random = randomR (One, Six)
 
 bestOrWorst :: Bool -> [DieFace] -> DieFace
 bestOrWorst True = maximum
@@ -222,14 +230,23 @@ instance Num DieFace where
 
 type CharacterIdentifier = (Player, Int)
 
-owner :: CharacterIdentifier -> Player
+cidEq :: (Coercible a b, Eq b) => a -> b -> Bool
-owner = fst
+cidEq = (==) . coerce
+
+owner :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Player
+owner cid' = fst cid
+  where
+    cid :: CharacterIdentifier
+    cid = coerce cid'
 
 ownerL :: Lens' CharacterIdentifier Player
 ownerL = _1
 
-isNecromancer :: CharacterIdentifier -> Bool
+isNecromancer :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Bool
-isNecromancer = snd >>> (== 0)
+isNecromancer cid' = (==0) $ snd cid
+  where
+    cid :: CharacterIdentifier
+    cid = coerce cid'
 
 showCID :: CharacterIdentifier -> Char
 showCID (cidOwner, idx) = (if cidOwner == Max then upperLetters else lowerLetters) !! idx
@@ -296,12 +313,29 @@ newtype Point = Point Natural
 enumeratePoints :: Natural -> Natural -> [Point]
 enumeratePoints w h = Point <$> [0..w * h - 1]
 
-data Trigger
+data Trigger a where
-  = TurnStart
+  TurnStart   :: Trigger ()
-  | TookDamage CharacterIdentifier
+  TookDamage  :: Trigger TargettedUnit
-  | Died CharacterIdentifier Point
+  Died        :: Trigger (TargettedUnit, Point)
-  | EndMove CharacterIdentifier
+  EndMove     :: Trigger ActingUnit
-  deriving (Eq, Show)
+
+deriving instance Eq (Trigger a)
+deriving instance Show (Trigger a)
+
+-- | Compare to triggers to check if they're equal
+--
+-- If they are, you get a proof of the equality of their associated data types.
+triggerEq :: Trigger a -> Trigger b -> Maybe (a :~: b)
+triggerEq TurnStart  TurnStart  = Just Refl
+triggerEq TookDamage TookDamage = Just Refl
+triggerEq Died       Died       = Just Refl
+triggerEq EndMove    EndMove    = Just Refl
+triggerEq _          _          = Nothing
+
+-- | A pair containing a 'Trigger' and its associated data
+--
+-- Effectively an event as a whole
+data Broadcast = forall d. Broadcast (Trigger d) d
 
 data OrthagonalDirection
   = North
@@ -404,8 +438,8 @@ data ProtoMovementSpecs = ProtoMovementSpecs
   , movCompelled       :: Bool -- ^ If movement can be stopped prematurely
   }
 
-basicMove :: CharacterIdentifier -> Effect
+basicMove :: ActingUnit -> Effect
-basicMove = InitMove $ ProtoMovementSpecs
+basicMove = (InitMove $ ProtoMovementSpecs
   { movVerb = "Move"
   , movFree' = Nothing
   , movMinimum = True
@@ -414,10 +448,10 @@ basicMove = InitMove $ ProtoMovementSpecs
   , movSpendTokens = True
   , movEndMoveTrigger = True
   , movCompelled = False
-  }
+  }) . (^. actingUnit)
 
-forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> CharacterIdentifier -> Effect
+forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> TargettedUnit -> Effect
-forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs
+forcedMove fmType amt compeller locus = (InitMove $ ProtoMovementSpecs
   { movVerb = show fmType
   , movFree' = Just True
   , movMinimum = False
@@ -426,7 +460,25 @@ forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs
   , movSpendTokens = False
   , movEndMoveTrigger = False
   , movCompelled = True
-  }
+  }) . (^. targettedUnit)
+
+-- | Designates a character identifier of the unit acting in an effect/event
+--
+-- Acting includes moving, attacking, or using an ability
+newtype ActingUnit = ActingUnit CharacterIdentifier
+  deriving (Eq, Show)
+
+-- | A lens reaching into `ActingUnit`
+actingUnit :: Lens' ActingUnit CharacterIdentifier
+actingUnit f (ActingUnit au) = ActingUnit <$> f au
+
+-- | Designates a character identifier of the unit being targetted by an effect/attack
+newtype TargettedUnit = TargettedUnit CharacterIdentifier
+  deriving (Eq, Show)
+
+-- | A lens reaching into `TargettedUnit`
+targettedUnit :: Lens' TargettedUnit CharacterIdentifier
+targettedUnit f (TargettedUnit au) = TargettedUnit <$> f au
 
 data Effect
 
@@ -436,13 +488,13 @@ data Effect
   | StartTurn
 
   -- | Send some trigger to every Unit
-  | Event Trigger
+  | Event Broadcast
 
   -- | Active player chooses whether they want to move or act first
-  | ChooseActMove CharacterIdentifier
+  | ChooseActMove ActingUnit
 
   -- | Active player may choose whether they want to act or move
-  | ActOrMove CharacterIdentifier
+  | ActOrMove ActingUnit
 
   -- | Mark the start of movement
   -- Can be finalized later with FinalizeMove
@@ -464,46 +516,51 @@ data Effect
   -- | Remove up to one token from the given category from a unit
   | forall n. Num n => DropToken
     (Token n) -- ^ The token category to drop from
-    CharacterIdentifier -- ^ Which character drops a token
+    TargettedUnit -- ^ Which character drops a token
 
   -- | Confirms a Move, placing the unit in the target space
   | ConfirmMove
 
   -- | Allow a character to Act
-  | Act CharacterIdentifier
+  | Act ActingUnit
 
   -- | Target a unit in a given range, then run a different event
   | Target
-    CharacterIdentifier -- ^ ACTing unit
+    ActingUnit -- ^ ACTing unit
     (Natural, Natural) -- ^ Range
-    (BoardState -> CharacterIdentifier -> Bool) -- ^ Target filter
+    (BoardState -> TargettedUnit -> Bool) -- ^ Target filter
-    (CharacterIdentifier -> [Effect]) -- ^ Ultimate effect
+    (TargettedUnit -> [Effect]) -- ^ Ultimate effect
 
   -- | Check if a character can body block
   -- If they can, offer a choice of target to the targetted player.  Pass result on to
   -- the effect.
-  | BodyBlock CharacterIdentifier (CharacterIdentifier -> [Effect])
+  | BodyBlock TargettedUnit (TargettedUnit -> [Effect])
 
   -- | Resolve an attack
   | ResolveAttack
-    CharacterIdentifier -- ^ Attacker
+    ActingUnit    -- ^ Attacker
-    Attack -- ^ Attack information
+    Attack        -- ^ Attack information
-    CharacterIdentifier -- ^ Target
+    TargettedUnit -- ^ Target
 
   | InflictDamage
     DamageType
     Natural             -- ^ Damage amount
-    CharacterIdentifier -- ^ Target
+    TargettedUnit       -- ^ Target
+
+  -- | Add a status effect to a character
+  | InflictStatusEffect
+    StatusEffect        -- ^ Effect to inflict
+    TargettedUnit       -- ^ Target
 
   | forall n. Num n => InflictTokens
     (Token n) -- ^ Token kind
     n -- ^ Token amount
-    CharacterIdentifier -- ^ Target
+    TargettedUnit -- ^ Target
 
-  | Kill CharacterIdentifier
+  | Kill TargettedUnit
 
   -- | Tap the active unit, change the active player
-  | EndTurn CharacterIdentifier
+  | EndTurn ActingUnit
 
 data Attack = Attack
   { headshotEffects :: [Effect]
@@ -553,16 +610,28 @@ data BaseStats = BaseStats
   , df          :: DieFace
   , arm         :: Armor
   , traits      :: [Trait]
-  , actions     :: [CharacterIdentifier -> Choice]
+  , actions     :: [ActingUnit -> Choice]
   }
 
 -- | Some effect which is activated by some trigger event
-data Hook h = Hook
+data Hook o = forall d. Hook
-  { hookTrigger :: Trigger -- ^ The trigger which should activate this effect
+  { hookTrigger :: Trigger d -- ^ The trigger which should activate this effect
   -- | What this effect does.  Recieves board & this character's CID
-  , hookEffect  :: BoardState -> h
+  , hookEffect  :: d -> BoardState -> o
   }
 
+-- | Evaluate a hook for a given trigger
+--
+-- If the trigger does not apply to this hook, then `mempty` is returned.
+hookToFunc :: Monoid h => Hook h -> Broadcast -> BoardState -> h
+hookToFunc (Hook {..}) (Broadcast trigger assocData) = case hookTrigger `triggerEq` trigger of
+  Just Refl -> hookEffect assocData
+  Nothing -> mempty
+
+-- | A version of `hookToFunc` which evaluates several hooks at once
+hooksToFunc :: Monoid h => [Hook h] -> Broadcast -> BoardState -> h
+hooksToFunc = mconcat . fmap hookToFunc
+
 -- | A modifier which conditionally affects thet value of some stat for a unit
 data Modifier = forall a. Monoid a => Modifier
   { modifierStat   :: Stat a -- ^ Which stat this modifier effects
@@ -584,13 +653,47 @@ data Trait = Trait
   , traitModifiers :: [Modifier] -- ^ Any modifiers this trait imposes
   }
 
+-- | Some inflicted/bestowed trait that applies to a character
+--
+-- Some status effects track internal state (here, the type variable a), which affect
+-- either what the effect does or how long it exists.
+--
+-- A couple examples of status effects:
+--  - Gargamox's Leech's "superate", which adds a Deathburst to a unit, and lasts for the
+--    whole game
+--  - C.A.R.C.A.S.'s Ammo Goblin's "bone shards" which causes the unit to take damage when
+--    pushed or pulled, and expires after dealing three damage or the end of the goblin's
+--    next turn.
+data StatusEffect = forall a. StatusEffect
+  { seName      :: String -- ^ The name of the effect
+  , seHooks     :: [Hook (a -> CharacterIdentifier -> [Effect])] -- ^ Triggers which produce effects
+  , seModifiers :: [Modifier] -- ^ Any stat modifiers inflicted by this effect
+
+  -- | Triggers which update the internal state or remove the effect
+  --
+  -- Returning `Just` updates the internal state, and returning `Nothing` removes the
+  -- effect completely.
+  , seUpdate    :: [Hook (a -> CharacterIdentifier -> Maybe a)]
+
+  -- | Whatever internal state is needed by this effect
+  , seState     :: a
+
+  -- | Render the internal state
+  --
+  -- Suffixed with the name when `show`ing this status effect
+  , seShowState :: a -> String
+  }
+
+instance Show StatusEffect where
+  show (StatusEffect {..}) = '+' : seName ++ ' ' : seShowState seState
+
 instance Show BaseStats where
   show stats = "===== " ++ name stats ++ " =====\nMV: " ++ show (mov stats) ++  "      DF: " ++ show (df stats) ++ "+      ARM: " ++ show (arm stats)
 
 newtype TokenCount = TokenCount (forall n. Token n -> n)
 
 instance Show TokenCount where
-  show tc = mconcat $ intersperse "\n" $ filter (/=[])
+  show tc = mconcat . intersperse "\n" $ filter (not . null)
     [ showHealth
     , showReload
     , " "
@@ -652,10 +755,16 @@ data Character = Character
   { _baseStats        :: BaseStats
   , _movedThisRound   :: Bool
   , _tokenCount       :: TokenCount
+  , _statusEffects    :: [StatusEffect]
   }
 
 instance Show Character where
-  show c = show (_baseStats c) ++ (if _movedThisRound c then "\n(already moved this round)" else "\n") ++ '\n' : show (_tokenCount c)
+  show c =
+    show (_baseStats c)
+    ++ (if _movedThisRound c then "\n(already moved this round)" else "\n")
+    ++ '\n' : show (_tokenCount c)
+    ++ '\n' : mconcat (intersperse "\n" (show <$> _statusEffects c))
+    ++ "\n"
 
 noTokens :: TokenCount
 noTokens = TokenCount noTokens'
@@ -699,8 +808,30 @@ makeLensesWith secondClassLensNames ''Hook
 
 makeLensesWith secondClassLensNames ''Trait
 
+instance Functor Hook where
+  fmap f (Hook {..}) = Hook {hookEffect = hookEffect <&> (<&> f), ..}
+  v <$ Hook {..} = Hook {hookEffect = const $ const v, ..}
+
+-- | Extract the hooks from a status effect, hiding internal state
+seGetHooks :: StatusEffect -> [Hook (CharacterIdentifier -> [Effect])]
+seGetHooks (StatusEffect {..}) = seHooks <&> (<&> ($ seState))
+
+seDoUpdate :: Broadcast -> BoardState -> CharacterIdentifier -> StatusEffect -> Maybe StatusEffect
+seDoUpdate (Broadcast trigger assocData) board cid (StatusEffect {..}) = case relevantUpdates of
+  [] -> Just $ StatusEffect {..}
+  Nothing : _ -> Nothing
+  Just newState : _ -> Just $ StatusEffect {seState = newState, ..}
+  where
+    seUpdate' = seUpdate & each . mapped %~ (($ cid) . ($ seState))
+    getRelevantHookEffects :: Hook t -> Maybe (BoardState -> t)
+    getRelevantHookEffects (Hook {..}) = case hookTrigger `triggerEq` trigger of
+      Just Refl -> Just $ hookEffect assocData
+      Nothing -> Nothing
+    relevantHooks = seUpdate' ^.. each . to getRelevantHookEffects . _Just
+    relevantUpdates = sequence relevantHooks board
+
 instantiate :: BaseStats -> Character
-instantiate stats = Character stats False noTokens & tokenCount . ofToken Health .~ hp stats
+instantiate stats = Character stats False noTokens [] & tokenCount . ofToken Health .~ hp stats
 
 clearUpToNTokens :: (Num a, Ord a) => Token a -> a -> Character -> Character
 clearUpToNTokens t n = tokenCount . ofToken t %~ clearUpToN n
@@ -740,10 +871,11 @@ untap = movedThisRound .~ False
 --
 -- This includes so called global modifiers, but in order to keep game rules seperate from
 -- the model, global modifiers must be provided as the first argument.
-computeStat_ :: [Modifier] -> BoardState -> CharacterIdentifier -> Stat a -> a
+computeStat_ :: (Coercible cid c, c ~ CharacterIdentifier) => [Modifier] -> BoardState -> cid -> Stat a -> a
-computeStat_ globalModifiers board cid stat = case allStatsAreMonoids stat of
+computeStat_ globalModifiers board cid' stat = case allStatsAreMonoids stat of
   HasMonoidInstance Refl ->
     let
+      cid = coerce cid'
       queryStatsL = each . to (queryModifier board cid stat)
       globalBonus = globalModifiers ^. queryStatsL
       traitBonus = board ^. ixCharacter cid . baseStats . traitsL . each . traitModifiersL . queryStatsL
@@ -751,24 +883,28 @@ computeStat_ globalModifiers board cid stat = case allStatsAreMonoids stat of
 
 -- | Activate all of the relevant hooks on the board
 --
--- Searches through all hooks in traits and global hooks, accumulates all their effects,
+-- Searches through all hooks in traits, statuse effects and global hooks, accumulates all
--- then adds all the resulting effects to the effect stack.  Similar to `computeStat_`,
+-- their effects, then adds all the resulting effects to the effect stack.  Then, all
--- this is additionall searches so called global hooks, but only recognizes global hooks
+-- necessary status effect updates are applied.  Similar to `computeStat_`, this is
--- passed as an argument.
+-- additionall searches so called global hooks, but only recognizes global hooks passed as
-runHooks_ :: [Hook [Effect]] -> Trigger -> BoardState -> BoardState
+-- an argument.
-runHooks_ globalHooks trigger board = board <++ characterEffects  <++ globalEffects
+runHooks_ :: [Hook [Effect]] -> Broadcast -> BoardState -> BoardState
+runHooks_ globalHooks trigger board = boardWithUpdates <++ allEffects
   where
-    filterActivatedL :: Traversal' (Hook a) (Hook a)
+    unitAllEffectHooks :: (CharacterIdentifier, Character) -> [Hook [Effect]]
-    filterActivatedL = filtered ((==trigger) . hookTrigger)
+    unitAllEffectHooks (cid, c) = allHooks <&> (?? cid)
-    unitHooksL :: SimpleFold Character (BoardState -> CharacterIdentifier -> [Effect])
+      where
-    unitHooksL = baseStats . traitsL . each . traitHooksL . each . filterActivatedL . hookEffectL
+        statusHooks :: [Hook (CharacterIdentifier -> [Effect])]
-    charRunHooks :: (CharacterIdentifier, Character) -> [Effect]
+        statusHooks = c ^.. statusEffects . each . to seGetHooks . each
-    charRunHooks (cid, c) =
+        classHooks :: [Hook (CharacterIdentifier -> [Effect])]
-      (c ^. unitHooksL) board cid
+        classHooks = c ^.. baseStats . traitsL . each . traitHooksL . each
-    characterEffects :: [Effect]
+        allHooks = statusHooks ++ classHooks
-    characterEffects = board ^. enumerateUnits . to charRunHooks
+    unitUpdateStatuses :: (CharacterIdentifier, Character) -> (CharacterIdentifier, Character)
-    globalEffects :: [Effect]
+    unitUpdateStatuses i@(cid, _) = i & _2 . statusEffects %~ mapMaybe (seDoUpdate trigger board cid)
-    globalEffects = (globalHooks ^. each . filterActivatedL . hookEffectL) board
+    unitHooks = board ^.. enumerateUnits . to unitAllEffectHooks . each
+    allHooks = unitHooks ++ globalHooks
+    allEffects = hooksToFunc allHooks trigger board
+    boardWithUpdates = board & enumerateUnits %~ unitUpdateStatuses
 
 instance Show BoardState where
   show board = join (intersperse "\n" showTiles) ++ '\n':showRound  ++ "\n" ++ showCharacters
@@ -914,11 +1050,13 @@ offsetB b = usingBoardDimensions b offset
 eachCID :: Monoid m => Getting m BoardState CharacterIdentifier
 eachCID = tiles . each . _1 . _Just
 
-ixCharacter :: CharacterIdentifier -> Traversal' BoardState Character
+ixCharacter :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Traversal' BoardState Character
-ixCharacter (player, indx) = characters . forPlayer player . ix indx
+ixCharacter cid = case coerce cid of (player, indx) -> characters . forPlayer player . ix indx
 
-renderCharacterHandle :: BoardState -> CharacterIdentifier -> String
+renderCharacterHandle :: (Coercible a b, b ~ CharacterIdentifier) => BoardState -> a -> String
-renderCharacterHandle board cid = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid
+renderCharacterHandle board cid' = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid
+  where
+    cid = coerce cid'
 
 eachCharacter :: Traversal' BoardState Character
 eachCharacter = characters . everybody . traverse
@@ -955,9 +1093,9 @@ enumerateUnits = enumerateUnits'
         fUnit :: Player -> Int -> Character -> f Character
         fUnit player indx c = snd <$> f ((player, indx), c)
         fRoster :: Player -> [Character] -> f [Character]
-        fRoster player roster = zipWithM (fUnit player) [0..] roster
         fCharacters :: PPair [Character] -> f (PPair [Character])
         fCharacters (PPair p1 p2) = PPair <$> fRoster Min p1 <*> fRoster Max p2
+        fRoster player = zipWithM (fUnit player) [0..]
 
 untappedUnits :: SimpleFold BoardState CharacterIdentifier
 untappedUnits = enumerateUnits . filtered (untapped . snd) . _1
@@ -968,14 +1106,14 @@ isAlive board cid = has (eachCID . filtered (== cid)) board
 pushEffects :: [Effect] -> BoardState -> BoardState
 pushEffects newEffects = effectStack %~ (newEffects ++)
 
-unitPosition :: BoardState -> CharacterIdentifier -> Maybe Point
+unitPosition :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Maybe Point
 unitPosition (BoardState {_movingUnit=Just (movingCid, movingPoint)}) cid
-  | movingCid == cid = Just movingPoint
+  | movingCid == coerce cid = Just movingPoint
-unitPosition (BoardState {_tiles}) cid = headMay $ catMaybes $ zipWith aux [0..] _tiles
+unitPosition (BoardState {_tiles}) cid = headMay . catMaybes $ zipWith aux [0..] _tiles
   where
     aux :: Natural -> (Maybe CharacterIdentifier, [EnvTile]) -> Maybe Point
     aux p (potentialCid, _)
-      | potentialCid == Just cid = Just $ Point p
+      | potentialCid == Just (coerce cid) = Just $ Point p
       | otherwise = Nothing
 
 atPoint :: Point -> Traversal' BoardState (Maybe CharacterIdentifier, [EnvTile])
@@ -990,7 +1128,7 @@ characterAt p f board = inner f board
     inner :: Traversal' BoardState (Maybe CharacterIdentifier)
     inner = atPoint p . _1 . filtered (/= board ^? movingUnit . _Just . _1)
 
-adjacentUnits :: BoardState -> CharacterIdentifier -> Maybe [CharacterIdentifier]
+adjacentUnits :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Maybe [CharacterIdentifier]
 adjacentUnits board cid = do
   originalLocation <- unitPosition board cid
   let adjacentTiles = usingBoardDimensions board adjacentPoints originalLocation
@@ -998,14 +1136,14 @@ adjacentUnits board cid = do
   let unitsAdjacent = mapMaybe (flip preview board . characterAt') adjacentTiles
   return unitsAdjacent
 
-adjacentAllies :: BoardState -> CharacterIdentifier -> Maybe [CharacterIdentifier]
+adjacentAllies :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Maybe [CharacterIdentifier]
 adjacentAllies board cid = filter (owner >>> (owner cid ==)) <$> adjacentUnits board cid
 
-isElevated :: BoardState -> CharacterIdentifier -> Bool
+isElevated :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Bool
-isElevated board cid = maybe False (\p -> elem Elevation $ board ^. terrainAt p) $ unitPosition board cid
+isElevated board cid = any (\p -> elem Elevation $ board ^. terrainAt p) $ unitPosition board cid
 
-removeUnit :: CharacterIdentifier -> BoardState -> BoardState
+removeUnit :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> BoardState -> BoardState
-removeUnit cid = tiles . each . _1 %~ mfilter (/= cid)
+removeUnit cid = tiles . each . _1 %~ mfilter (/= coerce cid)
 
 setUnit :: CharacterIdentifier -> Point -> BoardState -> BoardState
 setUnit character point = atPoint point . _1 ?~ character

src/Units/Carcass.hs

@@ -5,16 +5,15 @@ module Units.Carcass
 
 import GameModel
   ( adjacentAllies
+  , ActingUnit
   , Armor(..)
   , BaseStats(..)
   , BoardState
   , CharacterIdentifier
   , Choice
   , DamageType(..)
-  , Effect(..)
   , Stat(..)
   , Token(..)
-  , Trigger(..)
   , Trait(..)
   , Modifier(..)
   )
@@ -23,6 +22,7 @@ import Units.Components
   , anyTarget
   , buildAttack, inflictTokens, push
   )
+import Data.Monoid (Sum)
 
 gunwight :: BaseStats
 gunwight = BaseStats
@@ -35,7 +35,7 @@ gunwight = BaseStats
   , traits    = [formation]
   }
 
-gunwightActions :: [CharacterIdentifier -> Choice]
+gunwightActions :: [ActingUnit -> Choice]
 gunwightActions =
   [ buildAttack $ AttackT
     { tName            = "OL45"
@@ -66,6 +66,7 @@ formation = Trait
   , traitModifiers = [formationModifier]
   }
   where
+    formationF :: BoardState -> CharacterIdentifier -> Sum Int
     formationF board cid = if adjacentAllies board cid /= Just [] then 1 else 0
     formationModifier = Modifier
       { modifierStat = AttackDice

src/Units/Components.hs

@@ -8,6 +8,7 @@ module Units.Components
   , inflictTokens
   , push
   , pull
+  , inflictStatusEffect
   )
   where
 
@@ -18,10 +19,13 @@ import GameModel
   , Choice
   , DamageType
   , Effect(..)
-  , mkChoice, Token, forcedMove, ForcedMoveType (..), owner
+  , ActingUnit(..), TargettedUnit(..)
+  , actingUnit
+  , mkChoice, Token, forcedMove, ForcedMoveType (..), owner, StatusEffect, DieFace
   )
 
 import Numeric.Natural (Natural)
+import Lens.Micro
 
 -------------------------
 -- Attacks & Abilities --
@@ -30,7 +34,7 @@ import Numeric.Natural (Natural)
 data AttackT = AttackT
   { tName            :: String
   , tRange           :: (Natural, Natural)
-  , tValidTargets    :: BoardState -> CharacterIdentifier -> Bool
+  , tValidTargets    :: BoardState -> TargettedUnit -> Bool
   , tMelee           :: Bool
   , tDamageType      :: DamageType
   , tDamageAmount    :: Natural
@@ -38,16 +42,16 @@ data AttackT = AttackT
   , tStandardEffects :: [ProtoEffect]
   }
 
-anyTarget :: BoardState -> CharacterIdentifier -> Bool
+anyTarget :: BoardState -> TargettedUnit -> Bool
 anyTarget = const $ const True
 
-buildAttack :: AttackT -> CharacterIdentifier -> Choice
+buildAttack :: AttackT -> ActingUnit -> Choice
 buildAttack (AttackT {..}) attacker = mkChoice tName [targetEffect]
   where
     attackDetails target = Attack
-      ((sequence $ sequence tHeadshotEffects attacker) target)
+      (mkEffect attacker target tHeadshotEffects)
       tMelee
-      ((sequence $ sequence tStandardEffects attacker) target)
+      (mkEffect attacker target tStandardEffects)
       tDamageType
       tDamageAmount
     attackEffect target = [ResolveAttack attacker (attackDetails target) target]
@@ -58,20 +62,64 @@ data SelfAbilityT = SelfAbilityT
   , tEffects :: [ProtoEffect]
   }
 
-mkSelfAbility :: SelfAbilityT -> CharacterIdentifier -> Choice
+mkSelfAbility :: SelfAbilityT -> ActingUnit -> Choice
-mkSelfAbility (SelfAbilityT {..}) cid = mkChoice tName (sequence (sequence tEffects cid) cid)
+mkSelfAbility (SelfAbilityT {..}) cid = mkChoice tName (mkEffect cid (TargettedUnit $ cid ^. actingUnit) tEffects)
 
 -----------------------------
 --------- Effects -----------
 -----------------------------
 
-type ProtoEffect = CharacterIdentifier -> CharacterIdentifier -> Effect
+-- | Indicates a possible argument to a protoeffect
+--
+-- A valid argument to a protoeffect is any argument with which provide by placing the
+-- protoeffect in an `Effect`.  For example, a `DieFace` is a valid question because there
+-- exists an `Effect` which accepts a type @`DieFace` -> [`Effect`]@.
+--
+-- In additon, the actor and target (respectively) are available in the context, to enable
+-- asking questions about those things
+class Question t where
+  askQuestion :: ActingUnit -> TargettedUnit -> (t -> [Effect]) -> [Effect]
+
+instance Question ActingUnit where
+  askQuestion actor _ f = f actor
+
+instance Question TargettedUnit where
+  askQuestion _ target f = f target
+
+-- | A function which can be converted into a sequence of effects
+--
+-- Used in `buildProtoEffect` to create a `ProtoEffect`
+class ProtoEffectF t where
+  mkEffect :: ActingUnit -> TargettedUnit -> t -> [Effect]
+
+instance ProtoEffectF f => ProtoEffectF [f] where
+  mkEffect a t = (mkEffect a t =<<)
+
+instance ProtoEffectF Effect where
+  mkEffect _ _ = pure
+
+instance ProtoEffectF ProtoEffect where
+  mkEffect attacker target pe = mkEffect' attacker target pe
+
+instance (ProtoEffectF a, Question q) => ProtoEffectF (q -> a) where
+  mkEffect attacker target f = askQuestion attacker target (mkEffect attacker target <$> f)
+
+data ProtoEffect = forall f. ProtoEffectF f => MkProtoEffect f
+
+mkEffect' :: ActingUnit -> TargettedUnit -> ProtoEffect -> [Effect]
+mkEffect' attacker target (MkProtoEffect pe) = mkEffect attacker target pe
+
+mkEffects' :: ActingUnit -> TargettedUnit -> [ProtoEffect] -> [Effect]
+mkEffects' a t = (mkEffect a t =<<)
+
+inflictStatusEffect :: StatusEffect -> ProtoEffect
+inflictStatusEffect se =  MkProtoEffect $ InflictStatusEffect se
 
 inflictTokens :: Num n => Token n -> n -> ProtoEffect
-inflictTokens tokenType tokenCount _ = InflictTokens tokenType tokenCount
+inflictTokens tokenType tokenCount = MkProtoEffect $ InflictTokens tokenType tokenCount
 
 genericShift :: ForcedMoveType -> Natural -> ProtoEffect
-genericShift fmType amount puller = forcedMove fmType amount (owner puller) (Left puller)
+genericShift fmType amount = MkProtoEffect $ (\(ActingUnit puller) -> forcedMove fmType amount (owner puller) (Left puller))
 
 push :: Natural -> ProtoEffect
 push = genericShift Push

src/Units/Debug.hs

@@ -4,12 +4,16 @@ module Units.Debug
   where
 
 import GameModel
-  ( Armor(..)
+  ( Armor(..), ActingUnit
   , BaseStats(..)
   , CharacterIdentifier
   , Choice
   , DamageType(..)
-  , Token(..)
+  , Token(..), StatusEffect (..)
+  , Hook(..), Effect(..)
+  , Trigger(..), BoardState
+  , TargettedUnit(..)
+  , targettedUnit
   )
 
 import Units.Components
@@ -18,8 +22,11 @@ import Units.Components
   , buildAttack
   , SelfAbilityT(..)
   , mkSelfAbility, inflictTokens, pull, push
+  , inflictStatusEffect
   )
 
+import Lens.Micro
+
 basic :: BaseStats
 basic = BaseStats
   { name      = "Basic Debug Unit"
@@ -31,7 +38,7 @@ basic = BaseStats
   , traits    = []
   }
 
-basicActions :: [CharacterIdentifier -> Choice]
+basicActions :: [ActingUnit -> Choice]
 basicActions =
   [ buildAttack $ AttackT
     { tName            = "Peashooter"
@@ -102,7 +109,36 @@ basicActions =
     , tEffects         = [inflictTokens SpeedSlow 1]
     }
   , mkSelfAbility $ SelfAbilityT
-    { tName            = "Get String"
+    { tName            = "Blood Shield"
-    , tEffects         = [inflictTokens StrWeak 1]
+    , tEffects         = [inflictStatusEffect bloodShield]
     }
-  ]
+  ]
+
+bloodShield :: StatusEffect
+bloodShield = StatusEffect
+  { seName = "Blood Shield"
+  , seHooks =
+    [ Hook
+      { hookTrigger = TookDamage
+      , hookEffect = damageHookEffect
+      }
+    ]
+  , seModifiers = []
+  , seUpdate =
+    [ Hook
+      { hookTrigger = TookDamage
+      , hookEffect = damageHookDecrement
+      }
+    ]
+  , seState = 1
+  , seShowState = \n -> '(' : replicate n '*' ++ ")"
+  }
+  where
+    damageHookEffect :: TargettedUnit -> BoardState -> Int -> CharacterIdentifier -> [Effect]
+    damageHookEffect (TargettedUnit injuredUnit) _ _ us =
+      [InflictTokens VitalVulnr 1 (TargettedUnit us) | injuredUnit == us ]
+    damageHookDecrement :: TargettedUnit -> BoardState -> Int -> CharacterIdentifier -> Maybe Int
+    damageHookDecrement damagedUnit _ n  us
+     | damagedUnit ^. targettedUnit == us && n > 1 = Just $ pred n
+     | damagedUnit ^. targettedUnit == us = Nothing
+     | otherwise = Just n

src/Util.hs

@@ -8,7 +8,6 @@ module Util
   , note
   ) where
 
-import Data.Bool (bool)
 import Lens.Micro.TH (LensRules, lensRules, lensField, DefName (TopName))
 import Language.Haskell.TH (mkName, nameBase)
 import Lens.Micro
@@ -24,7 +23,7 @@ infixl 4 ??
 f ?? a = ($ a) <$> f
 
 secondClassLensNames :: LensRules
-secondClassLensNames = lensRules & lensField .~ (\_ _ n -> [TopName $ mkName $ nameBase n ++ "L"])
+secondClassLensNames = lensRules & lensField .~ (\_ _ n -> [TopName . mkName $ nameBase n ++ "L"])
 
 data Never